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

創業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
    #!/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
使い方のようなもの
世界カレンダー?

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スクリプト卸問屋