Perl/CGIスクリプト卸問屋は創業以来4,595,586,511名のお客様にご愛顧いただいております。

創業132年を誇る超老舗Perl/CGIスクリプト卸問屋へようこそ。当店では最先端技術駆使して作成したスクリプトを格安のパッケージにして販売するかもしれませんが現在は産地直送のため時価です。当社が持てる技術の粋を集めた7行シリーズをよろしく!(結構適当なのは内緒)

%ENV
DOCUMENT_ROOT /home/tonya/public_html/
GATEWAY_INTERFACE CGI/1.1
HTTP_ACCEPT text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
HTTP_ACCEPT_ENCODING gzip
HTTP_HOST tonya.usamimi.info
HTTP_USER_AGENT CCBot/2.0 (http://commoncrawl.org/faq/)
HTTP_X_FORWARDED_FOR 54.81.76.247, 10.0.0.4
HTTP_X_VARNISH 771112
PATH /usr/local/bin:/usr/bin:/bin
QUERY_STRING d=2415919104&source=project/2ch/test/read.cgi
REMOTE_ADDR 54.81.76.247
REMOTE_PORT 14058
REQUEST_METHOD GET
REQUEST_URI /cgi-bin/index.cgi?d=2415919104&source=project/2ch/test/read.cgi
SCRIPT_FILENAME /home/tonya/public_html/cgi-bin/index.cgi
SCRIPT_NAME /cgi-bin/index.cgi
SERVER_ADDR 10.0.0.8
SERVER_ADMIN tonya@usamimi.info
SERVER_NAME tonya.usamimi.info
SERVER_PORT 80
SERVER_PROTOCOL HTTP/1.1
SERVER_SIGNATURE <address>Apache Server at tonya.usamimi.info Port 80</address>
SERVER_SOFTWARE Apache
UNIQUE_ID W05cmgoAAAgAAKjyVOQAAABK
@INC (キャッシュ更新中は激重になります)
適当に動かしてみる
ダウンロードとか
  1. いらない ダウンロード project/2ch/test/read.cgi
    #!/usr/local/bin/perl
    
    my $title = '2ch 過去ログ ';
    my $base  = 'http://tonya.usamimi.info/cgi-bin/project/2ch/test/read.cgi';
    
    # ディレクトリツリーの構成は2chと同じで
    #
    # http://pc8.2ch.net/
    #     test/
    #         read.cgi (このファイル)
    #     hp/
    #         subject.txt
    #         dat/
    #             1143690384.dat
    #             1152587673.dat
    #     php/
    #         subject.txt
    #         dat/
    #             1153652403.dat
    #
    # こんな感じです。
    # 適当に *.dat を放り込んで subject.txt を更新すれば使えるはずです。
    #
    # 設定終わり
    
    (undef, my ($board, $thread, $start, $stop)) = split /\W+/, substr($ENV{'PATH_INFO'} || '', 0, 256), 6;
    $board = defined $board && $board =~ /(\w{1,64})/ ? $1 : '';
    $thread = defined $thread && $thread =~ /(\w{1,32})/ ? $1 : '';
    if (defined $start && $start =~ /(\d{1,4})/ && 1 <= $1 && $1 <= 1000) {
        $start = int $1;
        $stop = defined $stop && $stop =~ /(\d{1,4})/ && $start <= $1 && $1 <= 1000 ? int $1 : $start;
    } else {
        $start = 1;
        $stop = 1001;
    }
    
    my $html = <<'HTML';
    <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
    <html lang="ja">
    <head>
    <meta http-equiv="Content-Type" content="text/html; charset=Shift_JIS">
    <meta http-equiv="Content-Script-Type" content="text/javascript">
    <meta http-equiv="Content-Style-Type" content="text/css">
    <base href="$base">
    <title>$title</title>
    <script type="text/javascript">
    <!--
    function wopen(url) {
      width  = "640";
      height = "400";
      window.open(
        "$base" + url.replace(new RegExp("^.*\.cgi", "i"), ""),
        "popup",
        "width=" + width + ",height=" + height + ",dependent=yes,hotkeys=yes,resizable=yes,scrollbars=yes,status=yes"
      );
    }
    function control() {
      document.all.control.innerHTML = Array(
        '<span onclick="history.back(); return false;">戻る<\/span>',
        '<span href="#" onclick="window.close()">閉じる<\/span>'
      ).join(' ');
    }
    -->
    </script>
    <style type="text/css">
    <!--
    .board {  }
    .control { text-align:center }
    .control span { color:blue; cursor:hand; text-decoration:underline; }
    .message {  }
    .thread {  }
    -->
    </style>
    </head>
    <body bgcolor="#efefef" text="black" link="blue" alink="red" vlink="#660099" onload="control()">
    $board
    $thread_title
    $thread
    $message
    $update
    <div class="control" id="control"> </div>
    </body>
    </html>
    HTML
    
    my $subject = 'subject.txt';
    my ($myself) = __FILE__ =~ /([^\\\/]+)$/;
    my @board = get_board('..');
    my %html = map +($_ => ''), $html =~ /\$(\w+)/g;
    
    $html{'title'} = $title;
    $html{'base'} = $base;
    $html{'board'} = join("\n", board_anchor($myself, @board));
    $html{'thread_title'} = '<br><font size="+1" color="red">';
    if (length $board) {
        if (grep "../$board" eq $_, @board) {
            $html{'update'} = qq{<p><font size="2"><a href="$myself/$board/update/">$boardのsubject.txt更新</a></font></p>};
            if ($thread eq 'update') {
                $html{'thread_title'} .= "$html{'title'} $boardのsubject.txt ";
                $html{'thread_title'} .= update_subject("../$board", $subject)
                    ? 'を更新しました。'
                    : 'の更新に失敗しました。';
                $html{'thread'} = join "\n", thread_anchor($board, $subject, $myself, @board);
            } elsif ($thread =~ /^\d{1,10}$/) {
                $html{'update'} = '';
                $html{'message'} = join "\n",
                    '<div class="message">',
                    do {
                        if (my @message = get_dat("../$board/dat/$thread.dat", $start, $stop)) {
                            if (defined $message[0][5]) {
                                $html{'title'} .= $message[0][5];
                                $html{'thread_title'} .= $message[0][5];
                            }
                            message2dl(@message);
                        } else {
                            $html{'title'} .= 'そんなスレッドないです。';
                            $html{'thread_title'} .= $html{'title'};
                            ();
                        }
                    },
                    '</div>';
            } else {
                $html{'thread_title'} .= $html{'title'};
                $html{'thread'} = join "\n", thread_anchor($board, $subject, $myself, @board);
            }
        } else {
            $html{'title'} .= 'そんな板ないです。';
            $html{'thread_title'} .= $html{'title'};
        }
    } else {
        $html{'thread_title'} .= $html{'title'};
    }
    $html{'thread_title'} .= '</font>';
    
    $html =~ s/\$(\w+)/$html{$1}/g;
    
    print "Content-Type: text/html\n",
    #    "Cache-Control: no-cache\n",
        "\n",
        $html;
    
    exit;
    
    
    sub board_anchor {
        my ($myself, @board) = @_;
        '<div class="board">',
        '<font size="2">',
        map((s{^[./]+}{}, qq{<a href="$myself/$_/">$_</a>})[1], sort @board),
        '</font>',
        '</div>';
    }
    
    sub thread_anchor {
        my ($board, $subject, $myself, @board) = @_;
        my $i = 0;
        '<p class="thread">',
        '<font size="2">',
        (
            map {
                my $dir = $_;
                sub {
                    $dir =~ s{^[./]+}{};
                    map qq{<a href="$myself/$dir/$_->[0]/">} . (++$i) . ": $_->[1]</a> ", @_;
                }->(get_subject("$dir/$subject"));
            } grep $_ eq "../$board", @board
        ),
        '</font>',
        '</p>';
    }
    
    sub message2dl {
        my @message = @_;
        '<dl>',
        map(
            '<dt>'
                . $_->[0]
                . ' :'
                . (length $_->[2]
                        ? qq{<a href="mailto:$_->[2]"><b>$_->[1] </b></a>}
                        : qq{<font color="green"><b>$_->[1] </b></font>})
                . qq{$_->[3]<dd>}
                . autolink(add_popup($_->[4]))
                . '<br><br>',
            @message
        ),
        '</dl>';
    }
    
    sub add_popup {
        if (my $str = shift) {
            $str =~ s/(?<=<a href=)((["']?)([^ "'<>]+?)\2\starget=(["']?)_blank\4)(>)/$1 onmouseover="wopen('$3')"$5/g;
            $str;
        }
    }
    
    sub autolink {
        if (my $str = shift) {
            $str =~ s{h?(ttps?://[\w#\%&*+./:=?\@~-]+)}{<a href="h$1">h$1</a>}g;
            $str;
        }
    }
    
    sub update_subject {
        my ($dir, $subject) = @_;
        my $result;
        my @subject;
        foreach (get_thread("$dir/dat")) {
            if (open my $fh, $_) {
                my $mtime = (stat $fh)[9];
                chomp(my $line = <$fh>);
                if (0 <= (my $position = rindex $line, '<>')) {
                    push @subject, [$mtime, 0, (/(\d{1,10}\.dat)$/)[0], substr $line, $position + length '<>'];
                    1 while <$fh>;
                    $subject[-1][1] = $.;
                }
                close $fh;
            } else {
                warn $!;
            }
        }
        if ("$dir/$subject" =~ m{^(\../\w{1,64}/\w{1,64}\.\w{1,4})$} && open my $fh, "> $1") {
            $dir =~ s{^[./]+}{};
            $result = print $fh map "$_->[2]<>$_->[3] ($_->[1])\n", sort { $b->[0] <=> $a->[0] } @subject;
            $result = close $fh && $result;
        } else {
            warn $!;
        }
        $result;
    }
    
    sub get_dat {
        my ($path, $start, $stop) = @_;
        my @dat;
        if (open my $fh, $path) {
            local $_;
            while (<$fh>) {
                chomp;
                if ($start <= $.) {
                    push @dat, [$., split /<>/];
                }
                if ($stop <= $.) {
                    last;
                }
            }
            close $fh;
        }
        wantarray ? @dat : \@dat;
    }
    
    sub get_subject {
        my $filename = shift;
        my @subject;
        if (open my $fh, $filename) {
            local $_;
            while (<$fh>) {
                chomp;
                push @subject, [split /<>/];
                $subject[-1][0] =~ tr/0-9//cd;
            }
            close $fh;
        } else {
            warn $!;
        }
        wantarray ? @subject : \@subject;
    }
    
    sub get_thread {
        my $dir = shift;
        my @thread;
        if (opendir my $dh, $dir) {
            @thread = map "$dir/$_",
                grep /^\d{1,10}\.dat$/,
                    readdir $dh;
            closedir $dh;
        } else {
            warn $!;
        }
        wantarray ? @thread : \@thread;
    }
    
    sub get_board {
        my $dir = shift || '.';
        my @board;
        if (opendir my $dh, $dir) {
            @board = map "$dir/$_",
                grep $_ ne '.' && $_ ne '..' && $_ ne 'test' && -d "$dir/$_",
                    readdir $dh;
            closedir $dh;
        } else {
            warn $!;
        }
        wantarray ? @board : \@board;
    }
  2. ソース ダウンロード project/7lines/Storable.pm
  3. ソース ダウンロード project/7lines/_cms.cgi
  4. ソース ダウンロード project/7lines/analysis.cgi
  5. ソース ダウンロード project/7lines/calendar.cgi
  6. ソース ダウンロード project/7lines/counter.cgi
  7. ソース ダウンロード project/7lines/csv.cgi
  8. ソース ダウンロード project/7lines/excel.cgi
  9. ソース ダウンロード project/7lines/gc.cgi
  10. ソース ダウンロード project/7lines/hinomaru.cgi
  11. ソース ダウンロード project/7lines/http.cgi
  12. ソース ダウンロード project/7lines/httpd.pl
  13. ソース ダウンロード project/7lines/mail.cgi
  14. ソース ダウンロード project/7lines/navi.cgi
  15. ソース ダウンロード project/7lines/o.cgi
  16. ソース ダウンロード project/7lines/reverse.cgi
  17. ソース ダウンロード project/7lines/sum.cgi
  18. ソース ダウンロード project/7lines/tournament.cgi
  19. ソース ダウンロード project/7lines/upload.cgi
  20. ソース ダウンロード project/aabb.cgi
  21. ソース ダウンロード project/diary.cgi
  22. ソース ダウンロード project/download.cgi
  23. ソース ダウンロード project/explorer.cgi
  24. ソース ダウンロード project/gallery.cgi
  25. ソース ダウンロード project/mailer.cgi
  26. ソース ダウンロード project/message.cgi
  27. ソース ダウンロード project/mod_chat.cgi
  28. ソース ダウンロード project/research.cgi
  29. ソース ダウンロード project/rss.cgi
使い方のようなもの
世界カレンダー?
Sister Projects

©2018 Perl/CGIスクリプト卸問屋