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

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

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