創業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スクリプト卸問屋