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

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

%ENV
@INC (キャッシュ更新中は激重になります)
適当に動かしてみる
  1. 格子
  2. チャット
  3. HTTP
  4. 魔方陣
ダウンロードとか
  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
    #!/usr/local/bin/perl
    
    use CGI qw/:standard -no_xhtml -nosticky/;
    
    my %dict = (
        'action'         => 'message.cgi',
        'filename'       => './message.dat',
        'charset'        => 'Shift_JIS',
        'lang'           => 'ja',
        'title'          => '(秘)伝言',
        'form'           => '新規伝言',
        'submit_button'  => '送信',
        'name'           => 'お名前',
        'subject'        => '件名',
        'id'             => 'id',
        'mtime'          => '更新日時',
        'message'        => 'メッセージ',
        'read'           => '既読',
        'read_img'       => 'read.gif',
        'read_style'     => 'border:1px solid green',
        'unread'         => '未読',
        'unread_img'     => 'unread.gif',
        'unread_style'   => 'border:1px solid red',
        'delete'         => '削除',
        'delete_img'     => 'delete.gif',
        'delete_style'   => 'background-color:silver',
        'name_len'       => 20,
        'subject_len'    => 30,
        'message_len'    => 2000,
        'records'        => 100,
        'status'         => '状態',
        'not_found'      => 'id が見つかりませんでした。',
        'start_table'    => '一覧(テーブル)',
        'start_list'     => '一覧(リスト)',
        'rewrite'        => '書き直し',
        'success'        => '書き込みました。',
        'auth'           => '認証しました。',
        'injustice'      => 'パスワードが一致しませんでした。',
        'delete_button'  => '削除',
        'deleted'        => '削除しました。',
        'modify_button'  => '修正',
        'update_button'  => '更新',
        'updeted'        => '更新しました。',
        'retry'          => '再試行',
        'failure'        => '重複しています。',
        'quote_default'  => '無編集',
        'quote_add'      => '引用',
        'quote_del'      => '引用削除',
        'reserve_button' => 'やめる',
        'pass'           => 'パスワード',
        'require'        => '(必須)',
        'max_anchor'     => 16,
        'diff'           => 9 * 60 * 60,
        'textarea_cols'  => 60,
        'textarea_rows'  => 6,
        'format'         => '%04d/%02d/%02d-%02d:%02d:%02d',
        'style'          => q{
            b { color:red; }
            body { font-size:90%; }
            dl dt { color:#d2691e; font-weight:bold; }
            img { border:0px; }
            table { border-collapse:collapse; }
            td, th { border:1px solid gray; }
        },
    );
    
    #以下は変更しないほうが無難です。
    
    $CGI::POST_MAX = 0;
    foreach (grep /^\w+_len$/, keys %dict) {
        $CGI::POST_MAX += $dict{$_};
    }
    $CGI::POST_MAX *= 10;
    
    my $obj = Message->new(param 'mode');
    foreach (keys %dict) {
        $obj->set($_) = $dict{$_};
    }
    foreach (qw/name subject message/) {
        $obj->set($_ . '_notice') = '最大 ' . $obj->get($_ . '_len') . ' 文字です。';
    }
    $obj->set('records_notice') = '記録数は最大 ' . $obj->get('records') . ' 件でそれ以上は自動的に削除されます。';
    
    print $obj->execute();
    
    exit;
    
    
    package File;
    
    use Data::Dumper;
    
    sub get_data {
        my ($self, $filename) = @_;
        my $data = '';
        if (open my $fh, "< $filename") {
            eval { flock $fh, 2 };
            read $fh, $data, -s $fh;
            close $fh;
        } else {
            warn $!;
        }
        no strict 'vars';
        eval $data;
    }
    
    sub put_data {
        my ($self, $filename, @data) = @_;
        my $result;
        if (open my $fh, "+< $filename") {
            eval { flock $fh, 2 };
            if (print $fh Dumper(@data)) {
                $result = truncate $fh, tell $fh;
            }
            close $fh;
        } else {
            warn $!;
        }
        $result;
    }
    
    
    package Util;
    
    sub nl2br {
        my ($self, $str) = @_;
        $str =~ s/\n/<br>/g;
        $str;
    }
    
    sub mb_substr {
        my ($self, $str, $start, $stop, $charset) = @_;
        $start ||= 0;
        $stop ||= length $str;
        my $pattern = {
            'Shift_JIS' => qr/[\n\x20-\x7e\xa1-\xdf]|[\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc]/,
            'EUC-JP'    => qr/[\n\x20-\x7e]|[\x8e\xa1-\xfe][\xa1-\xfe]|\x8f[\xa1-\xfe][\xa1-\xfe]/,
        }->{$charset || 'Shift_JIS'};
        my $result = '';
        my ($i, $j) = (0) x 2;
        while ($str =~ /($pattern)/g) {
            if ($start <= $i) {
                $result .= $1;
                if ($stop <= ++$j) {
                    last;
                }
            }
            $i++;
        }
        $result;
    }
    
    sub create_password {
        my ($self, $len) = @_;
        my @char = ('0'..'9', 'A'..'Z', 'a'..'z');
        my $password = '';
        $len ||= 8;
        for (1..$len) {
            $password .= $char[rand @char];
        }
        $password;
    }
    
    
    package HTML::Share;
    
    use CGI qw/:standard/;
    
    sub begin {
        my $self = shift;
        header(-charset => $self->get('charset')),
        start_html(
            -declare_xml => 1, 
            -encoding => $self->get('charset'),
            -head => [
                meta({
                    -http_equiv => 'Content-Style-Type',
                    -content    => 'text/css'
                }),
                style(
                    {-type => 'text/css'},
                    "\n" . comment($self->get('style')) . "\n"
                ),
            ],
            -lang => $self->get('lang'),
            -title => $self->get('title'),
        );
    }
    
    sub back {
        my $self = shift;
        ul(
            li [
                a({-href => $self->get('action')}, $self->get('start_table')),
                a({-href => $self->get('action') . '?mode=List'}, $self->get('start_list')),
            ],
        );
    }
    
    sub end {
        p({-style => 'color:teal'}, 'HIDEGON rev2.0'),
        end_html;
    }
    
    
    package Message::Form;
    
    use CGI qw/:standard/;
    
    sub execute {
        my $self = shift;
        $self->back(),
        start_form(-action => $self->get('action')),
        ul(
            li [
                $self->get('name') . ' ' . textfield(-name => 'name', -title => $self->get('name_notice')) . $self->get('require'),
                $self->get('subject') . ' ' . textfield(-name => 'subject', -title => $self->get('subject_notice')) . $self->get('require'),
                $self->get('message') . $self->get('require') . br . textarea(-name => 'message', -cols => $self->get('textarea_cols'), -rows => $self->get('textarea_rows'), -title => $self->get('message_notice')),
    #            map(filefield(-name => 'file' . $_), 0..2),
                submit($self->get('submit_button')),
            ],
        ),
        hidden(-name => 'mode', -value => param(-name => 'mode', -value => 'Confirm')),
        end_form;
    }
    
    
    package Message::Delete;
    
    use CGI qw/:standard/;
    
    sub execute {
        my $self = shift;
        my $data = $self->get_data();
        my $id = substr param('id') || '0', 0, 15;
        my $params = $self->id_exists($id, $data);
        $self->back(),
        $self->authenticate($params, param('pass'))
            ? do {
                foreach (@$data) {
                    if ($id eq $_->{'id'}) {
                        $_->{'mode'} |= 4;
                        $_->{'mtime'} = time;
                        $self->put_data($data);
                        last;
                    }
                }
                p($self->get('deleted'));
            }
            : dl(dt($self->get('injustice')));
    }
    
    
    package Message::Update;
    
    use CGI qw/:standard/;
    our @ISA;
    
    sub execute {
        my $self = shift;
        my $data = $self->get_data();
        my $id = substr param('id') || '0', 0, 15;
        my $params = $self->id_exists($id, $data);
        @ISA = qw/Message::Auth/;
        if ($self->authenticate($params, param('pass'))) {
            my %params;
            foreach (qw/name subject message/) {
                $params{$_} = $self->mb_substr($self->untaint(param($_), 0, $self->get($_ . '_len')));
            }
            unless (grep !length, values %params) {
                foreach (@$data) {
                    if ($_->{'id'} eq $id) {
                        while (my ($name, $value) = each %params) {
                            $_->{$name} = $value;
                        }
                        $self->put_data($data);
                        last;
                    }
                }
            }
        }
        $self->set('auth') = $self->get('updeted');
        $self->SUPER::execute();
    }
    
    
    package Message::Modify;
    
    use CGI qw/:standard/;
    
    sub execute {
        my $self = shift;
        my $data = $self->get_data();
        my $id = substr param('id') || '0', 0, 15;
        my $params = $self->id_exists($id, $data);
        $self->back(),
        $self->authenticate($params, param('pass'))
            ? do {
                if ((param('quote') || '') =~ /^([+-]?\d)$/) {
                    if (0 < $1) {
                        $params->{'message'} =~ s/^/>/mg;
                    } elsif ($1 < 1) {
                        $params->{'message'} =~ s/^>//mg;
                    }
                }
                param(-name => 'name', -value => $params->{'name'});
                param(-name => 'subject', -value => $params->{'subject'});
                start_form(-action => $self->get('action')),
                ul(
                    li [
                        $self->get('name') . ' ' . textfield(-name => 'name', -title => $self->get('name_notice')) . $self->get('require'),
                        $self->get('subject') . ' ' . textfield(-name => 'subject', -title => $self->get('subject_notice')) . $self->get('require'),
                        $self->get('message') . $self->get('require') . br . textarea(-name => 'message', -cols => $self->get('textarea_cols'), -rows => $self->get('textarea_rows'), -title => $self->get('message_notice'), -value => $params->{'message'}),
                        submit($self->get('update_button')),
                    ],
                ),
                hidden(-name => 'mode', -value => param(-name => 'mode', -value => 'Update')),
                hidden(-name => 'id'),
                hidden(-name => 'pass'),
                end_form,
                start_form(-action => $self->get('action')),
                ul(
                    li(
                        submit($self->get('reserve_button')),
                        hidden(-name => 'mode', -value => param(-name => 'mode', -value => 'Auth')),
                        hidden(-name => 'id'),
                        hidden(-name => 'pass'),
                    ),
                ),
                end_form;
            }
            : dl(dt($self->get('injustice')));
    }
    
    
    package Message::Write::Success;
    
    use CGI qw/:standard/;
    
    sub execute {
        my ($self, $pass) = @_;
        $self->back(),
        dl(
            dt($self->get('success')),
            dt($self->get('pass')),
            dd(b($pass)),
        );
    }
    
    
    package Message::Write::Failure;
    
    use CGI qw/:standard/;
    
    sub execute {
        my $self = shift;
        $self->back(),
        start_form(-action => $self->get('action')),
        dl(
            dt($self->get('failure')),
            dt(submit($self->get('rewrite'))),
        ),
        hidden(-name => 'name'),
        hidden(-name => 'subject'),
        hidden(-name => 'message'),
        hidden(-name => 'mode', -value => param(-name => 'mode', -value => 'Form')),
        end_form;
    }
    
    
    package Message::Write;
    
    use CGI qw/:standard/;
    our @ISA;
    
    sub execute {
        my $self = shift;
        my @names = qw/name subject message/;
        my %params;
        @params{@names} = map $self->mb_substr($self->untaint(param($_), 0, $self->get($_ . '_len'))), @names;
        @ISA = 'Message::Form';
        unless (grep !length, values %params) {
            @ISA = 'Message::Write::Failure';
            my $data = $self->get_data();
            if (!@$data or join("\0", sort @{$data->[0]}{@names}) ne join("\0", sort @params{@names})) {
                @ISA = 'Message::Write::Success';
                $params{'id'} = 1;
                $params{'mode'} = 1;
                $params{'mtime'} = time;
                $params{'pass'} = $self->create_password(16);
                $params{'id'} += $data->[0]{'id'} if ref $data->[0] eq 'HASH' && defined $data->[0]{'id'};
                unshift @$data, \%params;
                @$data = splice @$data, 0, $self->get('records');
                $self->put_data($data);
            }
        }
        $self->SUPER::execute($params{'pass'});
    }
    
    
    package Message::Confirm;
    
    use CGI qw/:standard/;
    
    sub execute {
        my $self = shift;
        $self->back(),
        start_form(-action => $self->get('action')),
        dl(
            dt($self->get('name')),
            dd(escapeHTML($self->mb_substr($self->untaint(param('name')), 0, $self->get('name_len')))),
            dt($self->get('subject')),
            dd(escapeHTML($self->mb_substr($self->untaint(param('subject')), 0, $self->get('subject_len')))),
            dt($self->get('message')),
            dd($self->nl2br($self->create_anchor(escapeHTML($self->mb_substr($self->untaint(param('message')), 0, $self->get('message_len')))))),
            dt(submit($self->get('submit_button'))),
            dd(
                hidden(-name => 'name'),
                hidden(-name => 'subject'),
                hidden(-name => 'message'),
                hidden(-name => 'mode', -value => param(-name => 'mode', -value => 'Write')),
            )
        ),
        end_form,
        start_form(-action => $self->get('action')),
        dl(
            dt(submit $self->get('rewrite')),
            dd(
                hidden(-name => 'name'),
                hidden(-name => 'subject'),
                hidden(-name => 'message'),
                hidden(-name => 'mode', -value => param(-name => 'mode', -value => 'Form')),
            ),
        ),
        end_form;
    }
    
    
    package Message::Auth;
    
    use CGI qw/:standard/;
    
    sub execute {
        my $self = shift;
        my $data = $self->get_data();
        my $id = substr param('id') || '0', 0, 15;
        my $params = $self->id_exists($id, $data);
        $self->back(),
        $self->authenticate($params, param('pass'))
            ? do {
                foreach (@$data) {
                    if ($id eq $_->{'id'}) {
                        $_->{'mode'} |= 2;
                        $_->{'mtime'} = time;
                        $self->put_data($data);
                        last;
                    }
                }
                p($self->get('auth')),
                dl(
                    dt($self->get('name')),
                    dd(escapeHTML($self->mb_substr($params->{'name'}, 0, $self->get('name_len')))),
                    dt($self->get('subject')),
                    dd(escapeHTML($self->mb_substr($params->{'subject'}, 0, $self->get('subject_len')))),
                    dt($self->get('message')),
                    dd($self->nl2br($self->create_anchor(escapeHTML($self->mb_substr($params->{'message'}, 0, $self->get('message_len')))))),
                ),
                start_form(-action => $self->get('action')),
                dl(
                    dt(submit($self->get('modify_button'))),
                    dd(
                        radio_group(
                            -name    => 'quote',
                            -values  => [0, 1, -1],
                            -default => 0,
                            -labels  => {0 => $self->get('quote_default'), 1 => $self->get('quote_add'), -1 => $self->get('quote_del')},
                        ),
                        hidden(-name => 'mode', -value => param(-name => 'mode', -value => 'Modify')),
                        hidden(-name => 'id'),
                        hidden(-name => 'pass'),
                    ),
                ),
                end_form,
                start_form(-action => $self->get('action')),
                dl(
                    dt(submit($self->get('delete_button'))),
                    dd(
                        hidden(-name => 'mode', -value => param(-name => 'mode', -value => 'Delete')),
                        hidden(-name => 'id'),
                        hidden(-name => 'pass'),
                    ),
                ),
                end_form;
            }
            : dl(
                dt($self->get('injustice')),
                dt(a({-href => $self->get('action') . '?mode=Entrance&id=' . escapeHTML($id)}, $self->get('retry'))),
            );
    }
    
    
    package Message::Entrance;
    
    use CGI qw/:standard/;
    
    sub execute {
        my $self = shift;
        my $data = $self->get_data();
        my $id = substr param('id') || '0', 0, 15;
        my $params = $self->id_exists($id, $data);
        $self->back(),
        $params
            ? do {
                my ($alt, $src, $style) = $self->get_status($params->{'mode'});
                start_form(-action => $self->get('action')),
                dl(
                    dt($self->get('status')),
                    dd(img({-src => $src, -alt => $alt, -style => $style})),
                    dt($self->get('name')),
                    dd(escapeHTML($self->mb_substr($params->{'name'}, 0, $self->get('name_len')))),
                    dt($self->get('subject')),
                    dd(escapeHTML($self->mb_substr($params->{'subject'}, 0, $self->get('subject_len')))),
                    dt($self->get('pass')),
                    dd(password_field(-name => 'pass')),
                    dt(submit($self->get('submit_button'))),
                    dd(
                        hidden(-name => 'mode', -value => param(-name => 'mode', -value => 'Auth')),
                        hidden(-name => 'id'),
                    ),
                ),
                end_form
            }
            : ul(li $self->get('not_found'));
    }
    
    
    package Message::List;
    
    use CGI qw/:standard/;
    
    sub execute {
        my $self = shift;
        my $data = $self->get_data();
        ul(
            li [
                a({-href => $self->get('action')}, $self->get('start_table')),
                a({-href => $self->get('action') . '?mode=Form'}, $self->get('form')),
            ],
        ),
        dl(
            map {
                my ($alt, $src, $style) = $self->get_status($_->{'mode'});
                dt(
                    escapeHTML($_->{'id'}),
                    a(
                        {-href => $self->get('action') . '?mode=Entrance&id=' . escapeHTML($_->{'id'})},
                        img({-src => $src, -alt => $alt, -style => $style, -title => escapeHTML($_->{'subject'})})
                    ),
                ),
                dd(
                    ul(
                        li [
                            escapeHTML($self->mb_substr($_->{'name'}, 0, $self->get('name_len'))),
                            escapeHTML($self->mb_substr($_->{'subject'}, 0, $self->get('subject_len'))),
                            $self->time2date($_->{'mtime'}),
                        ],
                    ),
                ),
            } @$data
        ),
        ul(li [$self->get('records_notice')]);
    }
    
    
    package Message::Table;
    
    use CGI qw/:standard/;
    
    sub execute {
        my $self = shift;
        my $data = $self->get_data();
        table(
            {-summary => $self->get('start_table')},
            Tr(
                th(
                    {-colspan => 5},
                    a({-href => $self->get('action') . '?mode=List'}, $self->get('start_list')),
                    a({-href => $self->get('action') . '?mode=Form'}, $self->get('form')),
                )
            ),
            Tr [
                th([
                    $self->get('id'),
                    $self->get('status'),
                    $self->get('name'),
                    $self->get('subject'),
                    $self->get('mtime'),
                ]),
                map {
                    my ($alt, $src, $style) = $self->get_status($_->{'mode'});
                    th([
                        escapeHTML($_->{'id'}),
                        a(
                            {-href => $self->get('action') . '?mode=Entrance&id=' . escapeHTML($_->{'id'})},
                            img({-src => $src, -alt => $alt, -style => $style, -title => escapeHTML($_->{'subject'})})
                        ),
                    ])
                        . td([
                            escapeHTML(
                                $self->mb_substr(
                                    $_->{'name'},
                                    0,
                                    $self->get('name_len')
                                )
                            ),
                            escapeHTML(
                                $self->mb_substr(
                                    $_->{'subject'},
                                    0,
                                    $self->get('subject_len')
                                )
                            ),
                            $self->time2date($_->{'mtime'}),
                        ]);
                } @$data
            ]
        ),
        ul(li [$self->get('records_notice')]);
    }
    
    
    package Message;
    
    our @ISA;
    
    sub new {
        my $class  = shift;
        my $mode   = substr shift || '', 0, 64;
        my $parent = 'Message::Table';
        $mode =~ tr/A-Za-z_//cd;
        no strict 'refs';
        if ($class && $mode && exists ${$class . '::'}{$mode . '::'}) {
            $parent = $class . '::' . $mode;
        }
        @ISA = ($parent, qw/HTML::Share File Util/);
        bless {}, ref $class || $class;
    }
    
    sub time2date {
        my $self = shift;
        my @date = gmtime $self->get('diff') + shift;
        sprintf $self->get('format'),
            $date[5] + 1900, $date[4] + 1, $date[3], @date[2, 1, 0];
    }
    
    sub untaint {
        my ($self, $str) = @_;
        $str = '' unless defined $str;
        $str =~ tr/\t/ /;
        $str =~ tr/\x00-\x09\x0b\x0c\x0e-\x1f\x7f//d;
        $str =~ s/\s+$//g;
        $str =~ s/^\s+//g;
        $str =~ s/\x0d\x0a|\x0d|\x0a/\n/g;
        $str =~ s/(?<=\n{3})\n+//g;
        $str =~ s/(?<= ) +//g;
        $str =~ s/(?<=[\n ]{6})[\n ]+//g;
        $str;
    }
    
    sub authenticate {
        my ($self, $params, $password) = @_;
        $password && ref $params eq 'HASH' && $params->{'pass'} eq $password ? !($params->{'mode'} & 4) : 0;
    }
    
    sub get_data {
        my $self = shift;
        my $data = $self->SUPER::get_data($self->get('filename'));
        ref $data eq 'ARRAY' ? $data : [];
    }
    
    sub put_data {
        my ($self, $data) = @_;
        $self->SUPER::put_data($self->get('filename'), $data);
    }
    
    sub id_exists {
        my ($self, $id, $data) = @_;
        my $params;
        if ($id && ref $data eq 'ARRAY') {
            foreach (@$data) {
                if (ref eq 'HASH' && $id eq $_->{'id'}) {
                    $params = $_;
                    last;
                }
            }
        }
        ref $params eq 'HASH' ? $params : undef;
    }
    
    sub get_status {
        my ($self, $mode) = @_;
        my %status = (
            1 => 'unread',
            3 => 'read',
            7 => 'delete',
        );
        exists $status{$mode}
            ? ($self->get($status{$mode}), $self->get($status{$mode} . '_img'), $self->get($status{$mode} . '_style'))
            : ('') x 3;
    }
    
    sub create_anchor {
        my ($self, $str) = @_;
        my $pattern = qr{(https?://[\w.-]{1,64}(?:/[&*+./;=?@~\w-]{0,64})?)};
        my $max = $self->get('max_anchor');
        my $i = 0;
        $str =~ s/$pattern/$i++ < $max ? qq{<a href="$1">$1<\/a>} : $1/eg;
        $str;
    }
    
    sub execute {
        my $self = shift;
        $self->begin(),
        $self->SUPER::execute(),
        $self->end();
    }
    
    sub AUTOLOAD : lvalue {
        my $self = shift;
        @{$self}{@_};
    }
  27. ソース ダウンロード project/mod_chat.cgi
  28. ソース ダウンロード project/research.cgi
  29. ソース ダウンロード project/rss.cgi
使い方のようなもの
世界カレンダー?
Sister Projects

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