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

創業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
    #!/usr/local/bin/perl
    
    my $title    = '123Mail';
    my $to       = 'tonya@usamimi.info';
    my $sendmail = '/usr/sbin/sendmail';
    my $style    = <<'STYLE';
    .EN { font-family:Verdana, Ariel, sans-serif }
    .JP { font-family:"MS UI Gothic", sans-serif }
    .invalid { color:#d2691e }
    .valid { color:silver }
    ol li { list-style:none }
    STYLE
    
    # 設定終わり
    # [Opera + SJIS添付ファイル名] はブラウザが勝手にエスケープしてしまうため
    # 正しく扱えません。
    
    use CGI qw/:standard/;
    
    my @names    = qw/name reply subject message file0 file1 priority submit/; # フォームの順番
    my $myself   = (__FILE__ =~ /([^\\\/]+)$/)[0];
    my @language = Language->lang();
    my $language = defined param('language') && param('language') =~ /\A(\d)\z/ ? $language[$1 % @language] : 'JP';
    my $mail     = new Mailer $language;
    my @form     = $mail->parse(@names);
    my $data     = $mail->create('to' => $to);
    $data =~ s/\s+$//;
    my $errorno  = $mail->execute($sendmail, $data);
    
    print header -charset => $mail->charset();
    print start_html
        -declare_xml => 1, 
        -encoding    => $mail->charset(),
        -head        => [
            meta({
                -http_equiv => 'Content-Style-Type',
                -content    => 'text/css'
            }),
            style
                {-type => 'text/css'},
                comment $style
        ],
        -lang  => $mail->lang(),
        -title => $title,
        -class => $language;
    print p map a({-href => "$myself?language=$_"}, $language[$_] eq $language ? strong($language[$_]) : $language[$_]), 0..$#language;
    print start_multipart_form -action => $myself;
    print ol li \@form;
    print hidden(-name => 'language');
    print end_form;
    print fieldset legend($mail->status()), strong $errorno;
    print pre escapeHTML $data;
    print p {-style => 'color:teal; text-align:right;'}, '123Mail 0.2.46';
    print end_html;
    exit;
    
    
    
    package Language::JP;
    
    sub dict {
        scalar {
            'lang'           => 'ja',
            'charset'        => {
                "\x81\x40"     => 'Shift_JIS',
                "\xa1\xa1"     => 'EUC-JP',
                "\xe3\x80\x80" => 'UTF-8'
            }->{' '},
            'mail_charset'   => 'iso-2022-jp',
            'file0_begin'    => '添付(最大250KB)',
            'file0_end'      => '任意',
            'file0_max_size' => 250000,
            'file1_begin'    => '添付(最大1MB)',
            'file1_end'      => '任意',
            'file1_max_size' => 1000000,
            'message_begin'  => 'メッセージ',
            'message_end'    => '1文字以上2000文字以下でかつ適当に改行してください。',
            'message_maxlen' => 2000,
            'name_begin'     => 'お名前',
            'name_end'       => '1文字以上30文字以下',
            'name_maxlen'    => 30,
            'priority_begin' => '重要度',
            'priority_end'   => '1:高 5:低',
            'reply_begin'    => 'メール',
            'reply_end'      => 'メールアドレスらしきものだけです。',
            'subject_begin'  => '件名',
            'subject_end'    => '1文字以上60文字以下',
            'subject_maxlen' => 60,
            'submit_label'   => '送信',
            'status'         => '終了ステータス(送信完了 : 0)',
        }
    }
    
    
    package Language::EN;
    
    sub dict {
        scalar {
            'lang'           => 'en',
            'charset'        => 'ISO-8859-1',
            'mail_charset'   => 'iso-8859-1',
            'file0_begin'    => 'File(Max 250KB)',
            'file0_end'      => 'Optional',
            'file0_max_size' => 250000,
            'file1_begin'    => 'File(Max 1MB)',
            'file1_end'      => 'Optional',
            'file1_max_size' => 1000000,
            'message_begin'  => 'Message',
            'message_end'    => '1-2048 bytes',
            'message_maxlen' => 2048,
            'name_begin'     => 'Name',
            'name_end'       => '1-64 bytes',
            'name_maxlen'    => 64,
            'priority_begin' => 'Priority',
            'priority_end'   => '1:H 5:L',
            'reply_begin'    => 'Mail',
            'reply_end'      => 'valid',
            'subject_begin'  => 'Subject',
            'subject_end'    => '1-64 bytes',
            'subject_maxlen' => 64,
            'submit_label'   => 'Send',
            'status'         => 'Status (Sent : 0)',
        }
    }
    
    
    package Language;
    
    sub lang {
        my $self = shift;
        no strict 'refs';
        sort map { uc substr $_, 0, -2 }
            grep /^[A-Za-z][0-9A-Za-z]{0,64}::$/,
                keys %{__PACKAGE__ . '::'};
    }
    
    sub dict {
        my ($self, $lang) = @_;
        $lang ||= 'JP';
        (__PACKAGE__ . '::' . uc $lang)->dict();
    }
    
    
    package Form::File0;
    
    use CGI qw/:standard/;
    
    sub form {
        my ($self, $validity) = @_;
        div
            {-id => $self->name()},
            strong($self->dict('begin')),
            filefield(-name => $self->name()),
            small({-class => $self->get_style($validity)}, $self->dict('end'));
    }
    
    sub validate {
        my $self = shift;
        $self->validate_filefield(scalar(param $self->name()), $self->dict('max_size'));
    }
    
    
    package Form::File1;
    
    use CGI qw/:standard/;
    
    sub form {
        my ($self, $validity) = @_;
        div
            {-id => $self->name()},
            strong($self->dict('begin')),
            filefield(-name => $self->name()),
            small({-class => $self->get_style($validity)}, $self->dict('end'));
    }
    
    sub validate {
        my $self = shift;
        $self->validate_filefield(scalar(param $self->name()), $self->dict('max_size'));
    }
    
    
    package Form::Message;
    
    use CGI qw/:standard/;
    
    sub form {
        my ($self, $validity) = @_;
        div
            {-id => $self->name()},
            strong($self->dict('begin')),
            small({-class => $self->get_style($validity)}, $self->dict('end')),
            br(),
            textarea(-name => $self->name(), -cols => 64, -rows => 10, -wrap => 'hard');
    }
    
    sub validate {
        my $self = shift;
        $self->validate_textarea(scalar(param $self->name()), $self->dict('maxlen'));
    }
    
    
    package Form::Name;
    
    use CGI qw/:standard/;
    
    sub form {
        my ($self, $validity) = @_;
        div
            {-id => $self->name()},
            strong($self->dict('begin')),
            textfield(-name => $self->name()),
            small({-class => $self->get_style($validity)}, $self->dict('end'));
    }
    
    sub validate {
        my $self = shift;
        $self->validate_textfield(scalar(param $self->name()), $self->dict('maxlen'));
    }
    
    
    package Form::Priority;
    
    use CGI qw/:standard/;
    
    sub form {
        my ($self, $validity) = @_;
        div
            {-id => $self->name()},
            strong($self->dict('begin')),
            popup_menu(-name => $self->name(), -values => [1..5], -default => 3),
            small({-class => $self->get_style($validity)}, $self->dict('end'));
    }
    
    sub validate {
        my $self = shift;
        int(defined param($self->name()) && param($self->name()) =~ /\A[1-5]\z/);
    }
    
    
    package Form::Reply;
    
    use CGI qw/:standard/;
    
    sub form {
        my ($self, $validity) = @_;
        div
            {-id => $self->name()},
            strong($self->dict('begin')),
            textfield(-name => $self->name()),
            small({-class => $self->get_style($validity)}, $self->dict('end'));
    }
    
    sub validate {
        my $self = shift;
        $self->validate_mailaddress(scalar(param $self->name()));
    }
    
    
    package Form::Subject;
    
    use CGI qw/:standard/;
    
    sub form {
        my ($self, $validity) = @_;
        div
            {-id => $self->name()},
            strong($self->dict('begin')),
            textfield(-name => $self->name()),
            small({-class => $self->get_style($validity)}, $self->dict('end'));
    }
    
    sub validate {
        my $self = shift;
        $self->validate_textfield(scalar(param $self->name()), $self->dict('maxlen'));
    }
    
    
    package Form::Submit;
    
    use CGI qw/:standard/;
    
    sub form {
        my $self = shift;
        div
            {-id => $self->name()},
            submit($self->dict('label'));
    }
    
    sub validate { -1 }
    
    
    package Form;
    
    sub name {
        lc +(caller =~ /([A-Za-z][0-9A-Za-z]*)$/)[0];
    }
    
    sub names {
        my ($self, @names) = @_;
        no strict 'refs';
        my %pkg = map { lc substr($_, 0, -2) => 1 }
            grep /^[A-Za-z][0-9A-Za-z_]{0,64}::$/,
                keys %{__PACKAGE__ . '::'};
        my %tmp;
        grep exists $pkg{$_} && !$tmp{$_}++, @names;
    }
    
    sub files {
        my $self = shift;
        no strict 'refs';
        sort map { lc substr $_, 0, -2 }
            grep /^File\d{0,64}::$/,
                keys %{__PACKAGE__ . '::'};
    }
    
    sub re {
        my $self = shift;
        {
            'ISO-8859-1' => '[\x20-\x7e]',
            'Shift_JIS'  => '[\x20-\x7e\xa1-\xdf]|[\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc]',
            'EUC-JP'     => '[\x20-\x7e]|[\x8e\xa1-\xfe][\xa1-\xfe]|\x8f[\xa1-\xfe][\xa1-\xfe]',
            'UTF-8'      => join(
                '|',
                '[\x20-\x7f]',
                '[\xc0-\xdf][\x80-\xbf]',
                '\xe0[\xa0-\xbf][\x80-\xbf]|[\xe1-\xef][\x80-\xbf]{2}',
                '\xf0[\x90-\xbf][\x80-\xbf]{2}|[\xf1-\xf7][\x80-\xbf]{3}',
                '\xf8[\x88-\xbf][\x80-\xbf]{3}|[\xf9-\xfb][\x80-\xbf]{4}',
                '\xfc[\x84-\xbf][\x80-\xbf]{4}',
                '\xfd[\x80-\xbf]{5}'
            ),
        }->{$self->charset()} || 'ISO-8859-1';
    }
    
    sub validate_mailaddress {
        my ($self, $str) = @_;
        int(defined $str && $str =~ /\A[0-9A-Za-z_.-]{1,64}\@[0-9A-Za-z.-]{1,64}\.[A-Za-z]{2,4}\z/);
    }
    
    sub validate_textfield {
        my ($self, $str, $maxlen) = @_;
        my $re = $self->re();
        $re = qr/($re)/;
        int(defined $str && length $str && $str eq $self->mb_substr($str, 0, $maxlen, $re));
    }
    
    sub validate_textarea {
        my ($self, $str, $maxlen) = @_;
        my $re = $self->re();
        $re = qr/([\n\r]|$re)/;
        int(
            defined $str
                && length $str
                && $str eq $self->mb_substr($str, 0, $maxlen, $re)
                && $str =~ /\S/
                && $str !~ /.{254}/
                && $str !~ /[\x0d\x0a]{32}/
        );
    }
    
    sub validate_filefield {
        my ($self, $fh, $max_size) = @_;
        my $result = 0;
        if (defined $fh) {
            if ($fh eq '') {
                $result = 1;
            } elsif (ref $fh eq 'Fh') {
                $result = int(
                        -s $fh <= $max_size
                            && $self->validate_textfield($fh, 256)
                            && 0 < length $self->mb_filename($fh)
                    );
                unless ($result) {
                    close $fh;
                }
            }
        }
        $result;
    }
    
    sub mb_substr {
        my ($self, $str, $offset, $len, $re) = @_;
        my $result = '';
        if (defined $str) {
            warn $! if ref $re ne 'Regexp';
            $offset ||= 0;
            $len ||= length $str;
            $re ||= qr/([\x20-\x7e])/;
            for (my $i = 0; $i < $len && $str =~ /$re/g; $i++) {
                if ($offset <= $i) {
                    $result .= $1;
                }
            }
        }
        $result;
    }
    
    sub mb_filename {
        my ($self, $path) = @_;
        my $filename = '';
        my $re = $self->re();
        $re = qr/($re)/;
        while  ($path =~ /$re/g) {
            $filename .= $1;
            if ($1 eq '/' || $1 eq '\\') {
                $filename = '';
            }
        }
        $filename;
    }
    
    
    package Sendmail;
    
    use MIME::Base64;
    BEGIN {
        eval 'use Encode qw/from_to/; 1'
            or eval 'use Jcode; 1'
            or eval { require './jcode.pl' };
    }
    
    sub encode {
        my ($self, $str) = @_;
        eval { from_to($str, $self->charset(), $self->mail_charset()); 1 }
            or eval { Jcode::convert(\$str, 'jis', {'Shift_JIS' => 'sjis', 'EUC-JP' => 'euc'}->{$self->charset()}, 'z'); 1 }
            or eval { jcode::convert(\$str, 'jis', {'Shift_JIS' => 'sjis', 'EUC-JP' => 'euc'}->{$self->charset()}, 'z') };
        $str;
    }
    
    sub mime_encode {
        my ($self, $str, $wrap) = @_;
        $wrap ||= 64;
        $wrap -= length "\t=?" . $self->mail_charset() . '?B?' . '?=';
        $wrap = 3 * int $wrap / 4;
        my @data = '';
        my $len = 0;
        my $re = $self->re();
        $re = qr/($re)/;
        while ($str =~ /$re/g) {
            my $tmp = $self->encode($1);
            $len += length $tmp;
            if ($len <= $wrap) {
                $data[-1] .= $tmp;
            } else {
                push @data, $tmp;
                $len = length $tmp;
            }
        }
        substr
            join(
                "\n",
                map {
                    chomp(my $data = encode_base64($_));
                    "\t=?" . $self->mail_charset() . '?B?' . $data . '?=';
                } @data
            ),
            1;
    }
    
    sub sendmail {
        my ($self, $path, $data) = @_;
        my $nl   = "\x0d\x0a";
        my $wrap = 76;
        $wrap = 3 * int $wrap / 4;
        $data =~ s/^\.$/../gm;
        $data =~ s/\n/$nl/g;
        if (open my $fh, "| $path -t") {
            print $fh $self->encode($data);
            print $fh $nl;
            if ($self->boundary()) {
                foreach (grep length $self->param($_), $self->files()) {
                    my $file = $self->param($_);
                    my $filename = $self->mime_encode($self->mb_filename($file), 60);
                    binmode $file;
                    print $fh
                        join $nl,
                            '--' . $self->boundary(),
                            'Content-Type: application/octet-stream;',
                            "\t" . 'name="' . $filename . '"',
                            'Content-Transfer-Encoding: base64',
                            'Content-Disposition: attachment;',
                            "\t" . 'filename="' . $filename . '"',
                            '',
                            '';
                    #メモリーの節約になっているんだろうか?
                    #CGI.pm や sendmail の仕様を調べるのが面倒で確認していない。
                    while (read $file, my $data, $wrap) {
                        chomp(my $line = encode_base64($data));
                        print $fh $line, $nl;
                    }
                    close $file;
                }
                print $fh '--' . $self->boundary() . '--' . $nl;
            }
            print $fh $nl;
            close $fh;
        }
        $? >> 8;
    }
    
    
    package Mailer;
    
    use CGI;
    BEGIN { @Mailer::ISA = qw/Language Sendmail Form/ }
    
    sub new {
        my ($class, $lang) = @_;
        bless {
            'cgi'        => CGI->new(),
            'errorno'    => 0,
            'style'      => ['invalid', 'valid'],
            'dict'       => __PACKAGE__->SUPER::dict($lang),
            'message_id' => join(
                    '.',
                    sprintf('%08x', time),
                    sprintf('%02x' x 4, split /\D/, $ENV{'REMOTE_ADDR'} || '0.0.0.0'),
                    sprintf('%x', $ENV{'REMOTE_PORT'} || 0),
                    sprintf('%x', rand 2 ** 16),
                ) . '@' . ($ENV{'SERVER_NAME'} || $ENV{'SERVER_ADDR'} || 'localhost'),
            'boundary'   => sprintf(
                '----=_NextPart_%03d_%04d_%04X%04X.%04X%04X',
                map rand $_, 1000, 10000, (0x10000) x 4
            ),
            'params'     => {},
        }, ref $class || $class;
    }
    
    sub cgi { shift->{'cgi'} }
    
    sub errorno { shift->{'errorno'} }
    
    sub get_style {
        my ($self, $i) = @_;
        $self->{'style'}[$i % @{$self->{'style'}}];
    }
    
    sub dict {
        my ($self, $key) = @_;
        $self->{'dict'}{lc +(caller =~ /([A-Za-z][0-9A-Za-z]*)$/)[0] . '_' . $key};
    }
    
    sub lang { shift->{'dict'}{'lang'} }
    
    sub charset { shift->{'dict'}{'charset'} }
    
    sub mail_charset { shift->{'dict'}{'mail_charset'} }
    
    sub status { shift->{'dict'}{'status'} }
    
    sub message_id { shift->{'message_id'} }
    
    sub boundary { shift->{'boundary'} }
    
    sub param {
        my ($self, $name, $value) = @_;
        $name = lc $name;
        if (defined $value) {
            $value =~ s/\x0d\x0a|\x0d|\x0a/\n/g;
            $self->{'params'}{$name} = $value;
        }
        $self->{'params'}{$name};
    }
    
    sub parse {
        my ($self, @names) = @_;
        @names = $self->names(@names);
    #    no strict 'refs'; # if $] < 5.008 ?
        map {
            my $validate_method = 'Form::' . ucfirst($names[$_]) . '::validate';
            my $form_method = 'Form::' . ucfirst($names[$_]) . '::form';
            my $validity = $self->$validate_method();
            $self->{'errorno'} |= ($validity & 1 ^ 1) << $_;
            $self->param($names[$_], 0 < $validity ? $self->cgi->param($names[$_]) : '');
            $self->$form_method($validity);
        } 0..$#names;
    }
    
    sub text_plain {
        my $self = shift;
        $self->{'boundary'} = '';
        qq{Content-Type: text/plain;\n\tcharset="} . $self->mail_charset() . '"',
        'Content-Transfer-Encoding: 7bit',
        'X-Priority: ' . $self->param('priority'),
        '',
        $self->param('message');
    }
    
    sub multipart_mixed {
        my $self = shift;
        'Content-Type: multipart/mixed;',
        "\t" . 'boundary="' . $self->boundary() . '"',
        'X-Priority: ' . $self->param('priority'),
        '',
        'This is a multi-part message in MIME format.',
        '',
        '--' . $self->boundary(),
        'Content-Type: text/plain;',
        "\t" . 'format=flowed;',
        "\t" . 'charset="' . $self->mail_charset() . '";',
        "\t" . 'reply-type=original',
        'Content-Transfer-Encoding: 7bit',
        '',
        $self->param('message');
    }
    
    sub create {
        my ($self, %param) = @_;
        foreach (keys %param) {
            $self->param($_, $param{$_});
        }
        join "\n",
            'Message-ID: <' . $self->message_id() . '>',
            'Reply-To: "' . $self->mime_encode($self->param('name')) . qq{"\n\t<} . $self->param('reply') . '>',
            'From: <' . $self->param('to') . '>',
            'To: <' . $self->param('to') . '>',
            'Subject: ' . $self->mime_encode($self->param('subject')),
            'Date: ' . sprintf('%s, %d %s %d %s', (split /\s+/, gmtime)[0, 2, 1, 4, 3]) . ' +0000',
            'MIME-Version: 1.0',
            grep(ref $self->param($_) eq 'Fh', $self->files())
                ? $self->multipart_mixed()
                : $self->text_plain();
    }
    
    sub execute {
        my ($self, $path, $data) = @_;
        $self->{'errorno'} = $self->errorno()
            ? $self->errorno() << 8
            : $self->sendmail($path, $data);
    }
  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スクリプト卸問屋