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