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

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

%ENV
@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
使い方のようなもの
世界カレンダー?

FR IT JP UK US

2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2018年の祝日
2018年1月
1 2 3 4 5 6
7 8 9 10 11 12 13
14 15 16 17 18 19 20
21 22 23 24 25 26 27
28 29 30 31
2018年2月
1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28
2018年3月
1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30 31
2018年4月
1 2 3 4 5 6 7
8 9 10 11 12 13 14
15 16 17 18 19 20 21
22 23 24 25 26 27 28
29 30
2018年5月
1 2 3 4 5
6 7 8 9 10 11 12
13 14 15 16 17 18 19
20 21 22 23 24 25 26
27 28 29 30 31
2018年6月
1 2
3 4 5 6 7 8 9
10 11 12 13 14 15 16
17 18 19 20 21 22 23
24 25 26 27 28 29 30
2018年7月
1 2 3 4 5 6 7
8 9 10 11 12 13 14
15 16 17 18 19 20 21
22 23 24 25 26 27 28
29 30 31
2018年8月
1 2 3 4
5 6 7 8 9 10 11
12 13 14 15 16 17 18
19 20 21 22 23 24 25
26 27 28 29 30 31
2018年9月
1
2 3 4 5 6 7 8
9 10 11 12 13 14 15
16 17 18 19 20 21 22
23 24 25 26 27 28 29
30
2018年10月
1 2 3 4 5 6
7 8 9 10 11 12 13
14 15 16 17 18 19 20
21 22 23 24 25 26 27
28 29 30 31
2018年11月
1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30
2018年12月
1
2 3 4 5 6 7 8
9 10 11 12 13 14 15
16 17 18 19 20 21 22
23 24 25 26 27 28 29
30 31
01月01日 元日
01月08日 成人の日
02月11日 建国記念の日
02月12日 振替休日
03月21日 春分の日
04月29日 昭和の日
04月30日 振替休日
05月03日 憲法記念日
05月04日 みどりの日
05月05日 こどもの日
07月16日 海の日
09月17日 敬老の日
09月23日 秋分の日
09月24日 振替休日
10月08日 体育の日
11月03日 文化の日
11月23日 勤労感謝の日
12月23日 天皇誕生日
12月24日 振替休日
Sister Projects

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