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

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

%ENV
@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
    #!/usr/local/bin/perl
    
    my $password      = '1111';
    my $filename      = './aabb.dat';
    my $max_filesize  = 50000000;
    my $myself        = 'aabb.cgi';
    my $title         = 'aabb';
    my $charset       = 'Shift_JIS';
    my @lines         = (10, 20, 30, 50, 100);
    my $max_height    = 64;
    my $max_width     = 256;
    my $textarea_rows = 25;
    my $textarea_cols = 120;
    my $default       = <<'EOD';
    || ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄||
    ||【ルール】                                         ||
    ||・1回のレスでショボーンかシャキーンどっちか。同時に両方は×。            ||
    ||・ショボーンはageで。sageは×。わかりにくいショボーンも×。              ||
    ||・シャキーンは、それ以前のショボーンの全てに対して有効です。              ||
    || ショボーンに対するアンカーがなくてもOKです。                       ||
    ||・もしアンカー付きでまとめシャキーンするときにショボーンしていないレスに     ||
    || 対してシャキーンしたら、そのシャキーンは全部×。                      ||
    ||・メル欄にショボーンやシャキーンもOK。でも本文も書こうね。                ||
    ||・短編は全部まとめて1ショボーン。時間のカウントは1ページ目から       ||
    || 名前欄やメル欄にページ数も書こう。                          ||
    ||・虐殺AA&露骨・不快な下ネタAAは禁止でいこう。                 ||
    || 該当するAAを含むようなショボーン/シャキーンは×。                   ||
    ||・(´・ω・`)ショボーンと秒単位まで同時刻に(`・ω・´)シャキーンならネ申。      ||
    ||                                  。  ∧_∧      .||
    ||                                  \(´・ω・`)   いいかな・・?
    ||                                    ⊂ ⊂ )旦~   ||
    ||___∧ ∧___∧ ∧___ ∧ ∧__ ∧ ∧___| ̄ ̄ ̄ ̄ ̄ ̄ ̄|_||
          (  ∧ ∧__ (  ∧ ∧__(    ∧ ∧__(   ∧ ∧   ̄ ̄ ̄ ̄ ̄ ̄ ̄
       〜(_( ∧ ∧(  (  ∧ ∧_ (  ∧ ∧_ (  ∧ ∧  は〜い、先生。
         〜(_(   ,,)〜(_(   ,,)〜(_(   ,,)〜(_(   ,,)
           〜(___ノ  〜(___ノ   〜(___ノ   〜(___ノ
    EOD
    
    #設定終わり
    
    use CGI qw/:standard/;
    $CGI::POST_MAX = 2 ** 20;
    $CGI::DISABLE_UPLOADS = 1;
    charset($charset);
    
    my @errors;
    my $obj = new IO::Search;
    my $comment = param('comment');
    my $pass = param('pass');
    unless (defined $pass && $pass eq $password) {
        $pass = '';
    }
    
    $obj->set('filename') = $filename;
    $obj->set('filesize') = -s $obj->set('filename');
    $obj->set('max_id') = scalar $obj->max_id();
    $obj->set_lines(param('lines'));
    $obj->set_start(param('start'));
    $obj->set_word(param('word'));
    $obj->set_lines($lines[0]) unless grep $obj->get('lines') == $_, @lines;
    
    if (defined $comment && length $comment) {
        $comment = substr $comment, 0, $max_height * $max_width + 1024;
        $comment =~ tr/\x00-\x09\x0b\x0c\x0e-\x1f\x7f//d;
        $comment =~ s/\s+$//;
        if (!length $pass) {
            push @errors, 'パスワードが違います。';
        }
        if ($max_filesize < $obj->get('filesize')) {
            push @errors, 'ファイルが大きすぎます。';
        }
        if (!length $comment) {
            push @errors, '有効なコメントがありません。';
        }
        if ($max_height * $max_width < length $comment) {
            push @errors, 'コメントが大きすぎます。';
        }
        if ($max_height < $comment =~ s/\x0d\x0a|\x0d|\x0a/\n/g) {
            push @errors, '縦に長すぎます。';
        }
        if ($comment =~ /.{$max_width}/) {
            push @errors, '横に長すぎます。';
        }
        if (!@errors) {
            ($comment = aa_escape($comment)) =~ s/\n/<br>/g;
            $obj->add_data(time, 0, 0, 0, $comment);
        }
    }
    
    my @data = $obj->search();
    
    print header;
    print start_html(
            -encoding => $charset,
            -lang     => 'ja',
            -title    => $title,
        ),
        join(
            ' ',
            map a(
                    {-href => "$myself?start=" . $obj->get('start') . '&lines=' . $_ . '&word=' . $obj->get('word') . '&pass=' . $pass},
                    $obj->get('lines') == $_ ? b($_) : $_
                ),
                @lines
        ),
        ' | ',
        join(
            ' ',
            a(
                {-href => "$myself?start=1&lines=" . $obj->get('lines') . '&pass=' . $pass},
                '最初'
            ),
            sub {
                map(a({-href => "$myself?start=" . ($obj->get('start') - $_) . '&lines=' . $obj->get('lines') . '&word=' . $obj->get('word') . '&pass=' . $pass}, '-' . comma($_)), reverse @_),
                a(
                    {-href => "$myself?start=" . ($obj->get('start') - $obj->get('lines')) . '&lines=' . $obj->get('lines') . '&word=' . $obj->get('word') . '&pass=' . $pass},
                    '前へ'
                ),
                a(
                    {-href => "$myself?start=" . ($obj->get('start') + $obj->get('lines')) . '&lines=' . $obj->get('lines') . '&word=' . $obj->get('word') . '&pass=' . $pass},
                    '次へ'
                ),
                map(a({-href => "$myself?start=" . ($obj->get('start') + $_) . '&lines=' . $obj->get('lines') . '&word=' . $obj->get('word') . '&pass=' . $pass}, '+' . comma($_)), @_)
            }->(grep $obj->get('lines') < $_, map 10 ** $_, 1..log(1 <= $obj->set('max_id') ? $obj->set('max_id') : 1) / log 10),
            a(
                {-href => "$myself?start=" . $obj->get('max_id') . '&lines=' . $obj->get('lines') . '&pass=' . $pass},
                '最後'
            ),
        ),
    #    map(
    #        a(
    #            {-href => "$myself?start=" . ($obj->get('lines') * $_ + 1) . '&lines=' . $obj->get('lines') . '&word=' . $obj->get('word') . '&pass=' . $pass},
    #            $obj->get('lines') * $_ + 1 == $obj->get('start') ? b($_) : $_
    #        ),
    #        0..9
    #    ),
        ' | ',
        start_form(-action => $myself, -method => 'get', -style => 'display:inline'),
        textfield(-name => 'word'),
        submit(-value => '検索'),
        hidden(-name => 'lines', -value => $obj->get('lines')),
        hidden(-name => 'pass', -value => escapeHTML($pass)),
        end_form,
        length $obj->get('word') ? p('「' . b(escapeHTML($obj->get('word'))) . '」で検索して' . b($obj->get('found')) . '件中' . b($obj->get('start')) . '件目から' . b($obj->get('lines')) . '件表示しています。') : '',
        dl(map +(dt('[' . comma(int($_->[0])) . ']'), dd($_->[-1])), @data),
        p(comma($obj->set('filesize')), ' / ', comma($max_filesize), 'バイト'),
        start_form(-action => $myself),
        textarea(
            -name    => 'comment',
            -cols    => $textarea_cols,
            -rows    => $textarea_rows,
            -wrap    => 'off',
            -style   => 'font-family:"MS Pゴシック"',
            -default => $default,
        ),
        br,
        'パスワード', password_field(-name => 'pass'),
        submit(-value => '追加'),
        hidden(-name => 'start', -value => $obj->get('start')),
        hidden(-name => 'lines', -value => $obj->get('lines')),
        hidden(-name => 'pass', -value => escapeHTML($pass)),
        end_form,
        ul(li \@errors),
        p({-style => 'color:teal'}, 'aabb 0.3'),
        end_html;
    
    #$obj->_create_test_data(100_000, 700);
    
    exit;
    
    sub aa_escape {
        if (my $str = shift) {
            $str =~ s/</&lt;/g;
            $str =~ s/>/&gt;/g;
            $str =~ s/"/&quot;/g;
            $str;
        }
    }
    
    sub comma {
        if (my $str = shift) {
            ($str = reverse $str) =~ s/(\d\d\d)(?=\d)/$1,/g;
            scalar reverse $str;
        }
    }
    
    
    package IO::Search;
    
    sub new {
        bless {
            'filename'  => './aabb.dat',
            'filesize'  => 0,
            'delimiter' => "\t",
            'start'     => 1,
            'lines'     => 1,
            'word'      => '',
            'found'     => 0,
            'max_id'    => 0,
        }
    }
    
    sub set_start {
        my ($self, $start) = @_;
        if (defined $start && $start =~ /^(\d{1,10})$/) {
            my $lines = $self->get('lines') || 1;
            $self->set('start') = int $1;
            $self->set('start') = $self->get('max_id') if $self->get('max_id') < $self->get('start');
            $self->set('start') -= sub { $_[0] ? $_[0] : $lines }->($self->get('start') % $lines);
            $self->set('start') += 1;
            $self->set('start') = 1 if $self->get('start') < 1;
        }
        $self->get('start');
    }
    
    sub set_lines {
        my ($self, $lines) = @_;
        if (defined $lines && $lines =~ /^(\d{1,10})$/) {
            $self->set('lines') = int $1;
            $self->set('lines') = 0 if $self->get('lines') < 0;
        }
        $self->get('lines');
    }
    
    sub set_word {
        my ($self, $word) = @_;
        $self->set('word') = defined $word ? substr($word, 0, 128) : '';
    }
    
    sub search {
        my $self = shift;
        length $self->get('word')
            ? $self->word_search($self->get('start'), $self->get('lines'), $self->get('word'))
            : $self->binary_search($self->get('start'), $self->get('lines'));
    }
    
    sub binary_search {
        my ($self, $start, $lines) = @_;
        my @data;
        if (open my $fh, '<' . $self->get('filename')) {
            binmode $fh;
            my ($size, $position, $sign, $line) = ($self->get('filesize'), 0, 1, '');
            while ($sign && 1 <= $size) {
                $size /= 2;
                $position += $size * $sign;
                seek $fh, $position, 0;
                1 <= $size && <$fh>;
                $line = <$fh>;
                $sign = defined $line ? $start <=> ($line =~ /^(\d+)/)[0] : -1;
            }
            if (!$sign && defined $line) {
                my $delimiter = $self->get('delimiter');
                seek $fh, tell($fh) - length $line, 0;
                while (<$fh>) {
                    0 < $lines-- || last;
                    s/[\x0d\x0a]+$//;
                    push @data, [split /$delimiter/];
                }
            }
            close $fh;
        } else {
            warn $!;
        }
        @data;
    }
    
    sub word_search {
        my ($self, $start, $lines, $word) = @_;
        my @data;
        if (open my $fh, '<' . $self->get('filename')) {
            binmode $fh;
            my $delimiter = $self->get('delimiter');
            while (<$fh>) {
                if (0 <= index $_, $word) {
                    if (@data < $lines && --$start <= 0) {
                        s/[\x0d\x0a]+$//;
                        push @data, [split /$delimiter/];
                    }
                    $self->set('found')++;
                }
            }
            close $fh;
        } else {
            warn $!;
        }
        @data;
    }
    
    sub add_data {
        my ($self, @data) = @_;
        my $result;
        if (@data) {
            if (open my $fh, '+<' . $self->get('filename')) {
                eval { flock $fh, 2 };
                binmode $fh;
                my @line = $self->_max_id($fh);
                if (1 == @line) {
                    push @line, '';
                }
                if (
                    ++$line[0]
                        and $data[-1] ne $line[-1]
                        and $result = print $fh join($self->get('delimiter'), $line[0], @data) . "\n"
                    ) {
                    $self->set('filesize') = tell $fh;
                    $self->set('max_id') = $line[0];
                }
                $self->set_start($line[0]);
                close $fh;
            } else {
                warn $!;
            }
        }
        $result;
    }
    
    sub max_id {
        my $self = shift;
        my @data = -1;
        if (open my $fh, $self->get('filename')) {
            eval { flock $fh, 2 };
            @data = $self->_max_id($fh);
            close $fh;
        } else {
            warn $!;
        }
        wantarray ? @data : $data[0];
    }
    
    sub _max_id {
        my ($self, $fh, $buffer) = @_;
        my @data = 0;
        $buffer ||= 8192;
        binmode $fh;
        if (my $size = -s $fh) {
            @data = -1;
            my ($count, $data) = (0, '');
            my $offset = $size - sub { $_[0] ? $_[0] : $buffer }->($size % $buffer);
            while ($count < 2 && 0 <= $offset) {
                if (seek $fh, $offset, 0 and read $fh, my $tmp, $buffer) {
                    $count += $tmp =~ s{$/}{$/}g;
                    $data = "$tmp$data";
                }
                $offset -= $buffer;
            }
            if (seek $fh, 0, 2 and my @lines = split /\x0d\x0a|\x0d|\x0a/, $data) {
                my $delimiter = $self->get('delimiter');
                my @tmp = split /$delimiter/, $lines[-1];
                if ($tmp[0] =~ /^\d{1,10}$/) {
                    @data = @tmp;
                }
            }
        }
        wantarray ? @data : $data[0];
    }
    
    sub _create_test_data {
        my ($self, $lines, $maxlen) = @_;
        my ($str, $i) = ('0', 1);
        open my $fh, '>' . $self->get('filename') or die $!;
        for (1..$lines) {
            printf $fh join("\t", $_, 24 * 60 * 60 * $_, 0, 0, $_ . 'test_' . $str . ($str x rand $maxlen)) . "_OK\n";
        }
        close $fh;
    }
    
    sub AUTOLOAD : lvalue {
        my $self = shift;
        @{$self}{@_};
    }
  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スクリプト卸問屋