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

創業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 (https://commoncrawl.org/faq/)
HTTP_X_FORWARDED_FOR 54.198.126.110, 10.0.0.4
HTTP_X_VARNISH 79697373
PATH /usr/local/bin:/usr/bin:/bin
QUERY_STRING d=3489660928&source=project/research.cgi
REMOTE_ADDR 54.198.126.110
REMOTE_PORT 52615
REQUEST_METHOD GET
REQUEST_URI /cgi-bin/index.cgi?d=3489660928&source=project/research.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 W3T2lwoAAAgAAQFgqXIAAAAS
@INC (キャッシュ更新中は激重になります)
  1. /usr/local/lib/perl5/5.10.1/BSDPAN
  2. /usr/local/lib/perl5/site_perl/5.10.1/mach
  3. /usr/local/lib/perl5/site_perl/5.10.1
  4. /usr/local/lib/perl5/5.10.1/mach
  5. /usr/local/lib/perl5/5.10.1
  6. .
  1. 調査ディレクトリ
  2. 使用可能かもしれないライブラリ一覧
適当に動かしてみる
ダウンロードとか
  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
使い方のようなもの
世界カレンダー?
Sister Projects

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