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

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

%ENV
@INC (キャッシュ更新中は激重になります)
適当に動かしてみる
ダウンロードとか
  1. ソース ダウンロード project/2ch/test/read.cgi
  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
    #!/usr/local/bin/perl -Tw
    
    my $title        = '「リサーチ」ちゃいまんねん「レ・サーチ」でんねん';
    my @dictionaries = (
        './research.dic',
        './foo.dic',
        './bar.dic',
    );
    my $history      = './research.hst'; # あってもなくても OK
    my $sample       = './research.spl'; # 通常使用時は空文字列にしてください。
    my $filemode     = 0600;
    my $max_history  = 10;
    my $max_lines    = 1000;
    my $word_length  = 1024;
    my $word_delete  = 1;
    my $timeout      = 10;
    my $regexp_error = 1;
    my $charset      = 'Shift_JIS';
    my $css          = '.search b { background-color:yellow } .notice { font-size:80%; list-style:none; }';
    my @colors       = (
        ['blue',  '#ddddff'],
        ['green', '#ddffdd'],
        ['red',   '#ffdddd'],
        ['gray',  '#dddddd'],
    );
    my @favorites    = (
        'h?ttps?://[\w.-]+(/[\x21\x23-\x3b\x3d\x3f-\x7e]*)?',
        '[\w.-]+@[\w.-]+',
        '(?<=</b>)◆[\x21-\x7e]{8,10}',
        '(?<=\d{2}:\d{2}:\d{2}\s)ID:[\x21-\x3e\x40-\x7e]+?(?=<>)',
        '【種別】\s*[^<]+',
        '【条件】\s*[^<]+',
        '【言語】\s*[^<]*?perl[^<]*',
        '【言語】\s*[^<]*?php[^<]*',
        '【言語】\s*[^<]*?(?:perl|php)[^<]*',
        '^(?#小出しにしないで全部表示しる!)',
    );
    
    # 設定終わり
    # ファイル更新時に *.tmp を作成・削除するので注意してください。
    
    use CGI qw/:standard -no_xhtml -nosticky/;
    use Encode qw/from_to/;
    
    my @history;
    
    #@dictionaries = grep -f, @dictionaries;
    my $dict = param('dict') || 0;
    $dict = $dict =~ /^(\d{1,8})$/ ? $1 % @dictionaries : 0;
    
    my @mode = (
        ['key',  ' 検 索 ', ''],
        ['word', ' 追 加 ', ''],
        ['del0',  '削除確認',  ''],
        ['del0',  '削除実行',  'readonly'],
    );
    unless ($word_delete) {
        for (my $i = 0; $i < @mode; $i++) {
            if ($mode[$i][0] eq 'del0') {
                splice @mode, $i, 1;
                $i--;
            }
        }
    }
    my $mode = param('mode') || 0;
    $mode = $mode =~ /^(\d{1,2})$/ ? $1 % @mode : 0;
    
    my $obj = new Re;
    $obj->from($charset);
    $obj->to('utf8');
    $obj->len(64);
    
    my($re, @errors) = $obj->create_re(param('key'));
    my @del;
    if ($mode[$mode][0] eq 'del0') {
        if ($del[0] = $obj->create_re(param('del0'))) {
            $del[1] = substr scalar(param('del1')) || '', 0, 8192;
            $re = $del[0];
            $mode = $#mode;
        }
    }
    
    print header(-charset => $charset),
        start_html(
            -lang  => 'ja',
            -title => $title,
            -head  => [
                meta({
                    -http_equiv => 'Content-Style-Type',
                    -content    => 'text/css'
                }),
                style({-type => 'text/css'}, comment($css))
            ],
        ),
        start_form(-method => 'get', action => 'research.cgi'),
        popup_menu(
            -name       => 'dict',
            -values     => [0..$#dictionaries],
            -labels     => {map { $_ => ($dictionaries[$_] =~ /([^\\\/]+)$/)[0] } 0..$#dictionaries},
            -attributes => {map { -f $dictionaries[$_] ? () : ($_ => {-disabled => 'disabled'}) } 0..$#dictionaries}
        ),
        hidden(-name => 'mode', -value => $mode),
        textfield(-name => $mode[$mode][0], -style => "background-color:$colors[$mode][1]", $mode[$mode][2]),
        submit(-value => $mode[$mode][1]),
        ' ',
        a({-href => "research.cgi?dict=$dict&mode=" . (($mode + 1) % @mode)}, font({-color => $colors[$mode][0]}, 'モード')),
        length $sample ? copy($sample, $dictionaries[0], defined param('sample')) : (),
        defined $del[0] ? hidden(-name => 'del1', -value => urlencode($del[0])) : (),
        end_form,
        $regexp_error && @errors ? ul(li([map escapeHTML($_), '正規表現にエラーがあったため検索しませんでした。', @errors])) : ();
    
    local $SIG{'ALRM'} = sub {
        print p(strong("$timeout秒"), 'を超えたため強制終了しました。');
        exit;
    };
    if ($timeout) {
        eval { alarm $timeout };
    }
    
    if (defined $del[0] and defined $del[1] and urlencode($del[0]) eq $del[1]) {
        my $success;
        my $lines = 0;
        if (open my $in, "< $dictionaries[$dict]") {
            eval { flock $in, 2 };
            if ($success = open my $out, "> $dictionaries[$dict].tmp") {
                read $in, my $bom, 3;
                if (defined $bom and $bom eq "\xef\xbb\xbf") {
                    $success = print $out $bom;
                } else {
                    $success = seek $in, 0, 0;
                }
                my $re = $del[0];
                while (<$in>) {
                    if (/$re/) {
                        $lines++;
                    } elsif (!print $out $_) {
                        undef $success;
                        last;
                    }
                }
                $success = close $out && $success;
            }
            $success = close $in && $success;
            $success &&= rename "$dictionaries[$dict].tmp", $dictionaries[$dict];
        }
        if ($success) {
            my $pattern = escapeHTML('' . $del[0]);
            from_to($pattern, 'utf8', $charset);
            print p(i('削除結果:'), strong($pattern), 'にマッチした行を', strong("$lines行"), '削除しました。');
        } else {
            print p(i('削除結果:'), '削除に失敗しました。');
        }
    }
    
    if (defined(my $word = param('word'))) {
        ($word = substr $word, 0, $word_length) =~ tr/\x20-\x7e\x80-\xff//cd;
        $word =~ s/^\s+//;
        $word =~ s/\s+$//;
        my $utf8_word = $word;
        my $errormsg = '';
        {
            local $SIG{'__WARN__'} = sub { $errormsg .= join '', @_ };
            from_to($utf8_word, $charset, 'utf8');
        }
        if (length $errormsg) {
            warn $errormsg;
            print p(strong(escapeHTML($word)), 'には UTF-8 に変換できない文字が入っているかもしれません。');
        } elsif (length $utf8_word) {
            if (open my $fh, "+< $dictionaries[$dict]") {
                eval { flock $fh, 2 };
                my $lines = 0;
                my $duplication = 0;
                while (<$fh>) {
                    chomp;
                    if ($_ eq $utf8_word) {
                        $duplication = 1;
                        last;
                    }
                    $lines++;
                }
                if ($max_lines <= $lines) {
                    print p('登録数が', strong($max_lines), 'を超えているため追加しませんでした。');
                } elsif ($duplication) {
                    print p(strong(escapeHTML($word)), 'は重複しているため追加しませんでした。');
                } elsif (print $fh "$utf8_word\n") {
                    print p(strong(escapeHTML($word)), 'を追加しました。');
                } else {
                    print p(strong(escapeHTML($word)), 'の追加に失敗しました。');
                }
                close $fh;
            } else {
                print p(
                    '辞書ファイルに書き込めません。',
                    'ファイルが存在しているか、パーミッションが適切であるか確認してください。'
                );
            }
        }
    }
    
    if (ref $re eq 'Regexp') {
        my $found = 0;
        my $lines = 0;
        my @warnings;
        if (open my $fh, "< $dictionaries[$dict]") {
            read $fh, my $bom, 3;
            unless (defined $bom and $bom eq "\xef\xbb\xbf") {
                seek $fh, 0, 0;
            }
            print '<dl class="search">';
            local $SIG{'__WARN__'} = sub { push @warnings, join '', @_ };
            while (<$fh>) {
                chomp;
                my($html, $offset, $num) = ('', 0, 0);
                while (/$re/g) {
                    my($len, $strlen) = (pos, length $&);
                    $html .= escapeHTML(substr $_, $offset, $len - $strlen - $offset);
                    if ($strlen) {
                        $html .= b(escapeHTML(substr $_, $len - $strlen, $strlen));
                    }
                    $offset = $len;
                    $num++;
                }
                if ($num) {
                    $html .= escapeHTML(substr $_, $offset);
                    $found += $num;
                    $lines++;
                    from_to($html, 'utf8', $charset);
                    print dt("$.行目"), dd($html);
                }
                if (16 <= @warnings) {
                    print dt('警告が多過ぎたため強制終了しました。');
                    last;
                }
            }
            close $fh;
            my $pattern = '' . $re;
            from_to($pattern, 'utf8', $charset);
            print '</dl>',
                p(
                    i('検索結果:'),
                    strong(($dictionaries[$dict] =~ /([^\\\/]+)$/)[0]), 'を',
                    strong(escapeHTML($pattern)), 'で検索して',
                    strong("$lines行"), 'に',
                    strong("$found個"),
                    '見つかりました。'
                );
            @history = ($pattern =~ /:(.+)\)$/)[0] . "\n";
        } else {
            print p(
                '辞書ファイルを読み込めません。',
                'ファイルが存在しているか、パーミッションが適切であるか確認してください。'
            );
        }
        if ($^W and @warnings) {
            warn @warnings;
        }
    }
    
    if (open my $fh, "+< $history") {
        eval { flock $fh, 2 };
        push @history, grep !defined $history[0] || $history[0] ne $_, <$fh>;
        @history = splice @history, 0, $max_history;
        if (seek $fh, 0, 0 and print $fh @history) {
            truncate $fh, tell $fh;
        }
        close $fh;
        chomp @history;
    }
    
    print ul(
            {-class => 'notice'},
            li('Perlで使用可能な正規表現で検索します。'),
            li(i('検索結果'), 'が出ないときは検索語を変えてください。'),
            li('常に行単位のマッチングです。丸読みしたファイルに対して m/pattern/mg を適用した場合と同等だと思えばいいかもしれません。'),
            li({-title => '何でもありになってしまうので'}, '(?{ code }) はご利用いただけません。'),
            $timeout ? li($timeout, '秒間の時間制限が有効になっています。') : (),
            @favorites
                ? li(
                    dl(
                        dt({-title => '@favorites に登録してあるもの'}, '正規表現の例'),
                        array2dd($dict, @favorites)
                    )
                )
                : (),
            @history
                ? li(
                    dl(
                        dt('みんなこんな感じで検索してるよ。'),
                        array2dd($dict, @history)
                    )
                )
                : (),
        ),
        p({-style => 'color:teal'}, 'ReSearch'),
        end_html;
    
    chmod $filemode, $history, $sample, map { $_, "$_.tmp" } @dictionaries;
    
    exit;
    
    
    sub array2dd {
        my $dict = shift;
        dd(ol(li([map a({-href => "research.cgi?dict=$dict&mode=0&key=" . urlencode($_)}, escapeHTML($_)), @_])));
    }
    
    sub urlencode {
        my $str = shift;
        $str =~ s/([^\w.-])/uc '%' . unpack 'H2', $1/eg;
        $str;
    }
    
    sub copy {
        my($in_file, $out_file, $mode, $myself) = @_;
        $myself ||= (__FILE__ =~ /([^\\\/]+)$/)[0];
        my $buffer = 65535;
        my $anchor = ' ';
        if ($mode) {
            if (open my $in, "< $in_file") {
                binmode $in;
                if (open my $out, "+< $out_file") {
                    eval { flock $out, 2 };
                    binmode $out;
                    my $data;
                    while (read $in, $data, $buffer) {
                        print $out $data;
                    }
                    truncate $out, tell $out;
                    close $out;
                    $anchor .= a({-href => $myself}, 'ファイルのコピー作業をしました。失敗していてもエラーは出ません。');
                } else {
                    $anchor .= a({-href => $myself}, '出力ファイルが開けませんでした。');
                }
                close $in;
            } else {
                $anchor .= a({-href => $myself}, '入力ファイルが開けませんでした。');
            }
        } else {
            $anchor .= a({-href => "$myself?sample=1"}, 'サンプルデータをコピー');
        }
        $anchor;
    }
    
    
    package Re;
    
    use Encode qw/from_to/;
    
    sub new { bless {} }
    
    sub create_re {
        my($self, $str) = @_;
        compile_re(const_re(mb_convert_substr($str, @{$self}{qw/to from len/})));
    }
    
    sub const_re {
        my $str = shift;
        my $max_index = shift || 1;
        my $pattern = '';
        if (length $str) {
            my @pattern = split /  +/, $str, $max_index;
            $pattern = 1 < @pattern ? join('|', map "($_)", @pattern) : $pattern[0];
        }
        $pattern;
    }
    
    sub compile_re {
        my $pattern = shift;
        my $re;
        my @errors;
        if (length $pattern) {
            no re qw/taint eval debug/;
            local $SIG{'__DIE__'} = sub { push @errors, @_ };
            $re = eval 'qr/$pattern/i';
            warn @errors if $^W and @errors;
        }
        wantarray ? ($re, @errors) : $re;
    }
    
    sub mb_convert_substr {
        my($str, $to, $from, $len) = @_;
        $str = '' unless defined $str;
        $from ||= 'cp932';
        $to ||= 'utf8';
        $len = length $str unless defined $len;
        $str = substr $str, 0, $len;
        $str =~ tr/\x00-\x1f\x7f//d;
        local $SIG{'__WARN__'} = sub {} unless $^W;
        from_to($str, $from, $to);
        $str;
    }
    
    sub AUTOLOAD {
        my $self = shift;
        if (our $AUTOLOAD =~ /::([a-z][0-9a-z]*)$/) {
            $self->{$1} = shift;
        }
        $self;
    }
  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スクリプト卸問屋