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