version 1.20
by yav
This BBS is a backup system of
NEW BBS
Don't Let's scribble on this wall! ;-)
これは，www.oersted.co.jpが落ちてるときのための
バックアップ用の掲示板です．
通常は熊本校の掲示板を使ってね！
ココニ落書セシ者「なでなで」ノ刑ニ処ス．
タダシ「仰げば尊し」ヲ歌唱セシ者ハ刑ヲ減ズルモノトスル．
header_cookie: Set-Cookie: fortune___yav_wb_wb_cgi_debug_1=&standard%2ehtml&&&&&&Plain%2dtext&1&50; expires=Wed, 26 Nov 2025 14:36:01 GMT; style [standard.html] tz [] linkurl [1] HTTP_COOKIE: [] HTTP_USER_AGENT: [Mozilla/5.0 AppleWebKit/537.36 (KHTML, like Gecko; compatible; ClaudeBot/1.0; +claudebot@anthropic.com)] QUERY_STRING: [debug=1] Target encoding: [sjis] cmd: [] opkey: [] target: [] debugstr: [] next: [-1] previouts: [1]
#!/usr/bin/perl
# wb config file
# このファイルはいったんEUCに変換されてevalされるから，
# 日本語を使用しても安全だと思うよ．
$template = "standard.html"; # ページの雛型
$rootpasswd = 'xxx'; # <secret> (*) 管理者のパスワード
$userpasswd = 'xxx'; # <secret> (*) 利用者のパスワード
$dbdir = "xxx"; # <secret> (*) データファイルを置くとこ
$secure = 1; # (*) Secure mode (0:Insecure, 1:Secure)
$author = 'yav'; # (*) Set your name
$email = 'yav@bigfoot.com'; # (*) Set your E-mail address
$top = '../'; # (*) Set your Top web page URL
$tope = '../indexe.html'; # (*) Set your English Top web page URL
$topi = '../indexi.html'; # (*) Set your iMODE Top web page URL
$dbfilemax = 20; # (*) data fileの最大個数 (0で無制限)
$dbsizemax = 50000; # (*) data fileの最大バイト数 (0で無制限)
$artsizemax = 32000; # (*) article maximum size (0で無制限)
$remoteinfo = 0; # (*) 投稿者のIP/UAを 0:表示しない 1:表示する
$cookiename = 'fortune'; # cookieの名前
$cookietime = 60*60*24*31; # cookieの賞味期限 (60*60*24*31秒 = 31日間)
$denc = 'sjis'; # database encoding 'jis', 'euc', 'sjis' or ''
# '': 不明 (新たな書き込みは'sjis')
# $gzip = '/usr/bin/gzip'; # gzipのpathを書くと圧縮して出力
$cgilib = './cgi-lib.pl'; # cgi-lib.plのpathを書くとcgi-lib.plを使う
$ftype = './ftype.pl'; # ftype.plのpathを書くとftype.plを使う
$filedir = "$dbdir/file"; # アップロードファイルを置くディレクトリ
$logfile = "$filedir/log"; # logfile
$logenc = 'sjis'; # logfile encoding
$maxdata = 128*1024; # max file size
$txbps = 32*1024; # ファイルダウンロード速度制限 byte/sec
$maximgwidth = 640; # 画像横幅これ以上は縮小表示 0:無制限
$maximgheight = 480; # 画像縦幅これ以上は縮小表示 0:無制限
$previewall = 1; # HTML以外もプレビュー
@nghosts = ("nghost"); # 投稿を拒否するIP/ドメインリストファイル
@ngfiles = ("ngword", # 投稿NGワードリストファイル
"spamsub",
"spamlist",
"spambody");
# $version = "${version}a";
# $htmlck = 0; # HTML check しない
# $htmlck'attr_check = 0; # ' タグの属性チェックしない
$styleselect = 1; # 表示スタイルを選べるか？
# 0の場合は $templates[0]が使われる
# @templatesが1つしかなかったら0になる
$lastmodified = 0; # 1にするとHTTPヘッダにLast-modifiedを出力
# ただし表示スタイルが選べる場合には
# 出力されません
# テンプレートファイルとそれを選ぶときのメニューの名前のリスト
# ファイルネーム, メニュー名1, メニュー名2の項目は1個以上のタブで区切られる
# メニュー名の頭に'*'がついてたらその列のメニューが表示される
# ↓のサンプルだと，japanese.html, minibbs.html それと minibbs9.htmlのときは，
# Menu2の列が表示される
@templates =
(
# ---Filename--- ---Menu1--- ---Menu2---
"standard.html *Standard 標準",
"notable.html *No-table 表なし",
"japanese.html Japanese *日本語",
"english.html *English",
"minibbs.html MiniBBS10 *MiniBBS10",
"minibbs9.html MiniBBS9 *MiniBBS9",
"imode.html iMODE *iMODE",
"compact.html Compact *コンパクト",
);
$head_title = "Whiteboard"; # in <title>
$body_title_en = "$head_title"; # in <h1> and <a>
$body_title_ja = "落書するべからず!";
$body_title_i = "落書";
$body_title = "$body_title_en<br>$body_title_ja";
$body_top_message = "";
$body_lastpage_message = "<p><small>
<font color=red>This BBS is a backup system of
<a href=\"http://www.oersted.co.jp/~yav/wbb/wb.cgi\">NEW BBS</a></font><br>
<strike>Don't</strike> <em>Let's</em> scribble on this wall! <em>;-)</em><br>
<font color=red>これは，www.oersted.co.jpが落ちてるときのための
バックアップ用の掲示板です．
通常は<a href=\"http://www.oersted.co.jp/~yav/wbb/wb.cgi\">熊本校の掲示板</a>を使ってね！</font><br>
ココニ落書セシ者「なでなで」ノ刑ニ処ス．
タダシ「仰げば尊し」ヲ歌唱セシ者ハ刑ヲ減ズルモノトスル．
</small></p>";
$body_lastpage_message_en = "<p><small>
<font color=red>This BBS is a backup system of
<a href=\"http://www.oersted.co.jp/~yav/wbb/wb.cgi\">NEW BBS</a></font><br>
<strike>Don't</strike> <em>Let's</em> scribble on this wall! <em>;-)</em><br>
</small></p>";
$body_lastpage_message_ja = "<p><small>
<font color=red>これは，www.oersted.co.jpが落ちてるときのための
バックアップ用の掲示板です．
通常は<a href=\"http://www.oersted.co.jp/~yav/wbb/wb.cgi\">熊本校の掲示板</a>を使ってね！</font><br>
ココニ落書セシ者「なでなで」ノ刑ニ処ス．
タダシ「仰げば尊し」ヲ歌唱セシ者ハ刑ヲ減ズルモノトスル．
</small></p>";
$grep_message_ja = '<p>"<strong><kbd>%re%</kbd></strong>"の検索結果</p>';
$body_post_message = "";
$body_bottom_message = "";
$str_back_en = "Return home page"; # in <a>
$str_back = "ホームページに戻る";
$str_back_i = "Back";
$str_help_en = "Help";
$str_help = "解説";
$help_body_title_ja = "落書きのしかた";
$help_body_title_en = "$head_title help";
# 下記のように$stylesheetを設定すると見栄えを変更することができるよ！
# ただし，配色の都合で見苦しくなった表示スタイルがある場合は，
# a. @templateの該当する部分を'#'でコメントアウトする
# b. 該当するテンプレートファイルを削除する
# のどちらかの方法で表示スタイルとして選択できないようにしておくのが
# 親切でいいと思います．
#
# $stylesheet = '
# <link rel="STYLESHEET" type="text/css" href="../general.css">
# <style>
# <!--
# body { background-color: #ccffee; }
# .minibbssubject { background-color: #ffccaa; color: black; }
# .minibbsinfo { color: green; }
# .minibbsarticle { color: navy; }
# //-->
# </style>
# ';
# for BIGLOBE server
unlink("core") if -e "core";
1; # 戻り値 (今のとこ意味無し)
# Local Variables:
# mode:perl
# End:
#!/usr/local/bin/perl
#
# Whiteboard "Rakugaki" BBS CGI script
# written by yav <yav@bigfoot.com>
#
# Rakugaki BBS Support page --> http://www.oersted.co.jp/~yav/wb/
#
# Free! This CGI script is under public domain!
# For more informations, Look Rakugaki BBS Support page!
#
# このCGIスクリプトはパブリックドメインです．好き勝手使っていいよ！
# 設置方法等についての詳しい解説は，Rakugaki BBS Support pageを見てね．
#
$rcsid = q$Id: wb.cgi,v 1.7 2008/08/26 07:25:12 yav Exp $;
$version = "1.20";
#
# ($myname, $script, $configと$jcodeを除く) 以下の設定は，
# "config.pl"というファイルで変更することができます．
#
$myname = "wb.cgi";
$script = "wb.pl";
$config = "./config.pl";
$jcode = "./jcode.pl"; # 空にするとjcodeを使わない -> 日本語ダメ
$htmlck = "./htmlck.pl"; # 空にするとHTMLのチェックをしません
$template = "standard.html"; # ページの雛型
$wbpw = "wbpw.html"; # パスワード入力のページの雛型
$rootpasswd = 'xxx'; # <secret> (*) 管理者のパスワード
$userpasswd = 'xxx'; # <secret> (*) 利用者のパスワード
$dbdir = "xxx"; # <secret> (*) データファイルを置くとこ
$secure = 0; # (*) Secure mode (0:Insecure, 1:Secure)
$author = 'yav'; # (*) Set your name
$email = 'yav@bigfoot.com'; # (*) Set your E-mail address
$top = '../'; # (*) Set your Top web page URL
$tope = ''; # (*) Set your English Top web page URL
$topi = ''; # (*) Set your iMODE Top web page URL
$dbfilemax = 20; # (*) data fileの最大個数 (0で無制限)
$dbsizemax = 50000; # (*) data fileの最大バイト数 (0で無制限)
$artsizemax = 32000; # (*) article maximum size (0で無制限)
$remoteinfo = 0; # (*) 投稿者のIP/UAを 0:表示しない 1:表示する
$cookiename = 'fortune'; # cookieの名前
$cookietime = 60*60*24*31; # cookieの賞味期限 (60*60*24*7秒 = 31日間)
$yav = 'yav'; # このCGIを変更したら，ここに貴方の名前を
$yavemail = 'yav@bigfoot.com'; # ここにE-mail addressを書いてネ！
$denc = ''; # database encoding 'jis', 'euc', 'sjis' or ''
$ENV{'PATH'} = ''; # for taint perl
$gzip = ''; # gzipのpathを書くと圧縮して出力
$cgilib = './cgi-lib.pl'; # cgi-lib.plのpathを書くとcgi-lib.plを使う
$ftype = './ftype.pl'; # ftype.plのpathを書くとftype.plを使う
$filedir = "$dbdir/file"; # アップロードファイルを置くディレクトリ
$logfile = "$filedir/log"; # logfile
$logenc = 'sjis'; # logfile encoding
$rename_old = 0; # 変更不可
$maxdata = 1*1024*1024; # max file size
$txbps = 0; # ファイルダウンロード速度制限 byte/sec
$maximgwidth = 0; # 画像横幅これ以上は縮小表示 0:無制限
$maximgheight = 0; # 画像縦幅これ以上は縮小表示 0:無制限
$previewall = 0; # HTML以外もプレビュー
@nghosts = ("nghost"); # 投稿を拒否するIP/ドメインリストファイル
@ngfiles = ("ngword", # 投稿NGワードリストファイル
"spamsub",
"spamlist",
"spambody");
$styleselect = 1; # 表示スタイルを選べるか？
# 0の場合は $templates[0]が使われる
# @templatesが1つしかなかったら0になる
$lastmodified = 0; # 1にするとHTTPヘッダにLast-modifiedを出力
# ただし表示スタイルが選べる場合には
# 出力されません
$stylesheet = $debugstr = '';
@templates =
(
# ---Filename--- ---Menu1--- ---Menu2---
"standard.html *Standard ", # $styleselectが0の時の表示形式
"notable.html *No-table ",
"japanese.html Japanese ",
"english.html *English",
"minibbs.html MiniBBS10 ",
"minibbs9.html MiniBBS9 ",
"imode.html iMODE ",
"compact.html Compact ",
);
$head_title = "Whiteboard"; # in <title>
$body_title_en = "$head_title"; # in <h1> and <a>
$body_title_ja = "$head_title"; # in <h1> and <a>
$body_title_i = "$head_title"; # in <h1> and <a>
$body_title = "$head_title";
$body_top_message = "";
$body_lastpage_message = "";
$body_lastpage_message_en = "";
$body_lastpage_message_ja = "";
$grep_message_ja = $grep_message_en = '<p>Find "<strong><kbd>%re%</kbd></strong>" result</p>';
$body_post_message = "";
$body_bottom_message = "";
$str_back_en = "Return top page"; # in <a>
$str_back_i = "Back";
$str_back = "Return home page";
$str_help_en = "Help";
$str_help = "Help";
$help_body_title_ja = "$head_title help";
$help_body_title_en = "$head_title help";
# 下記の$stylesheetの設定で見栄えを変更することができるよ
#
# $stylesheet = '
# <link rel="STYLESHEET" type="text/css" href="../general.css">
# <style>
# <!--
# body { background-color: #ccffee; }
# .minibbssubject { background-color: #ffccaa; color: black; }
# .minibbsinfo { color: green; }
# .minibbsarticle { color: navy; }
# //-->
# </style>
# ';
require "$jcode" if $jcode;
$script = $myname if !-e $script;
# $config (初期値"config.pl")というファイルがあれば，読みこんで各種設定を変更
$mkcache = 0;
if (open(F, "$config")) {
local($file, $cache) = ("$config", "$config.cache");
local(*CACHE);
# 既にキャッシュがあるならそっちから読み込む
if (-e "$cache" &&
-M "$cache" < -M $config &&
-M "$cache" < -M $script &&
open(CACHE, "$cache")) {
close(F);
$_ = join('', <CACHE>);
close(CACHE);
/^((.|\n)*)$/;
$_ = $1;
$file = "$cache";
} else {
$_ = join('', <F>);
close(F);
s/\r\n/\n/g;
&jcode'convert(*_, 'euc') if $jcode; # sjisは'\'があるのでeucにする
$mkcache = 1; # 後でcacheを書き出すようにする
}
$config_data = $_;
eval($_);
&errprint("Eval error in $file:<br>\n $@\n") if $@;
}
$htmlck = 0 if !-e $htmlck;
if ($htmlck) {
require "$htmlck";
&htmlck'html_version("4.01 Transitional"); # '
}
$umask = $secure ? 0177 : 0111;
umask($umask);
$dbfile = "$dbdir/db";
$tope = $tope || $top;
$styleselect = 0 if @templates <= 1; # 表示スタイルの選択の余地がない
$lastmodified = 0 if $styleselect; # 表示スタイルが選択可能だと出力しない
# 必要ならconfig.plのキャッシュを生成
if ($mkcache) {
open(F, ">$config.cache") || &errprint("Can't open $config.cache ($!)");
print F $config_data;
close(F);
}
# 同名のCookieの場合おかしいことになりそうなのでディレクトリを付加
$_ = "$cookiename $ENV{'REQUEST_URI'}";
s/[^0-9A-Za-z]/_/g;
$cookiename = $_;
# receive cookie
foreach (split(/; */, $ENV{'HTTP_COOKIE'})) {
($n, $value) = split(/=/);
if ($n eq $cookiename) {
@COOKIE = split(/&/, $value);
last; # ignore upper level domain cookie
}
}
foreach (@COOKIE) {
&urldec;
}
# IE3.02a/Win3.1 は multipart-postがおかしい？
# MSIE 3.0, MSIE 3.01 MSIE 3.02 : Mozilla/2.0
$cgilib = '' if $ENV{'HTTP_USER_AGENT'} =~ /Sailor Pluto/;
$cgilib = '' if $ENV{'HTTP_USER_AGENT'} =~ m#Mozilla/[0-3]#;
if (-e $cgilib && -e $ftype) {
$enctype = 'enctype="multipart/form-data"';
} else {
$cgilib = $ftype = $enctype = '';
}
if ($cgilib) {
require "$cgilib";
require "$ftype" if $ftype;
$cgi_lib'writefiles = "$filedir/incoming"; # ' cgi-lib file writing dir
$cgi_lib'maxdata = $maxdata+1024; # ' +1024 for boundary and disposition lines
&ReadParse;
@importlist =
('usetable', 'style', 'tz', 'debug', 'pw', 'name',
'str', 'page', 'lastscan',
'uemail', 'uweb', 'ukey', 'title', 'type',
'previewtext', 'previewtype', 'previewname', 'previewtitle',
'fileinfo',
'linkurl', 'target', 'cmd', 'opkey', 'doc', 'artn',
're', 'grepmode', 'grepcase',
'fn');
foreach $key (@importlist) {
$_ = $in{$key};
if ($_) {
if ($key ne 'fn') { # $dlfileはEUCにしない
&jcode'convert(*_, 'euc') if $jcode; # '
}
$opt{$key} = $_;
}
}
} else {
# for method GET
foreach (split(/[&;]/, $ENV{'QUERY_STRING'})) {
($n, $_) = split(/=/);
&urldec;
$QUERY{$n} = $_;
}
# for method POST
while (<STDIN>) {
s/\n$//;
s/\r//g;
foreach (split(/[&;]/)) {
($n, $_) = split(/=/);
next unless $_;
&urldec;
if ($n ne 'fn') { # $dlfileはEUCにしない
&jcode'convert(*_, 'euc') if $jcode; # '
}
if ($n eq 'str') {
$str .= "$_\n";
} elsif ($n eq 'target') {
$target .= "\0" if (defined($target));
$target .= "$_";
} else {
s/\n$//;
$opt{$n} = "$_"; # Caution! NOT $_ perl4 on BIGLOBE www2s
}
}
}
}
($name, $style, $tz, $pw, $uemail, $uweb, $ukey, $texttype, $linkurl, $artn)
= @COOKIE;
$str = $str || $opt{'str'};
$style = $opt{'usetable'} || $QUERY{'usetable'} || $style;
$style = $opt{'style'} || $QUERY{'style'} || $style;
$tz = $opt{'tz'} || $QUERY{'tz'} || $tz;
$debugmode = $opt{'debug'} || $QUERY{'debug'};
$pw = $opt{'pw'} || $QUERY{'pw'} || $pw;
$name = $opt{'name'} || $QUERY{'name'} || $name;
$uemail = $opt{'uemail'} || $QUERY{'uemail'} || $uemail;
$uweb = $opt{'uweb'} || $QUERY{'uweb'} || $uweb;
$ukey = $opt{'ukey'} || $QUERY{'ukey'} || $ukey;
$srctitle = $opt{'title'} || $QUERY{'title'};
$texttype = $opt{'type'} || $QUERY{'previewtext'} || $texttype || 'Plain-text';
$previewtext = $opt{'previewtext'} || $QUERY{'previewtext'};
$previewtype = $opt{'previewtype'} || $QUERY{'previewtype'};
$previewname = $opt{'previewname'} || $QUERY{'previewname'};
$previewtitle = $opt{'previewtitle'} || $QUERY{'previewtitle'};
$fileinfo = $opt{'fileinfo'} || $QUERY{'fileinfo'};
$linkurl = $opt{'linkurl'} || $QUERY{'linkurl'} || $linkurl || 1;
$target = $target || $opt{'target'} || $QUERY{'target'};
$cmd = $opt{'cmd'} || $QUERY{'cmd'};
$opkey = $opt{'opkey'} || $QUERY{'opkey'};
$doc = $opt{'doc'} || $QUERY{'doc'};
$artn = $opt{'artn'} || $QUERY{'artn'} || $artn;
$artn = 50 if ($artn <= 0);
$uagent = $ENV{'HTTP_USER_AGENT'};
$uagent =~ s/\n.*//;
$dlfile = $opt{'fn'} || $QUERY{'fn'};
# $debugmode = 1 if $uhost =~ /\.oersted\.co\.jp$/;
# サイズを読みやすい形にする
$artsizemaxC = &sizestrc($artsizemax);
$maxdataC = &sizestrc($maxdata);
$artsizemaxK = &sizestrf($artsizemax);
$maxdataK = &sizestrf($maxdata);
sub sizestrc
{
local($_) = @_;
0 while s/(\d+)(\d\d\d)/$1,$2/;
$_;
}
sub sizestrf
{
local($_) = @_;
local(@f) = ('', 'K', 'M', 'G', 'T');
local($i);
for ($i = 0; $_ >= 1024 && $i < @f; $i++) {
$_ /= 1024;
}
sprintf("%.3g%s", $_, $f[$i]);
}
if ($styleselect) {
$style = ($uagent =~ /^Mozilla/) ? 'standard.html' : 'notable.html' if !$style;
} else {
($_) = split(/[ \t]+[*+-]?/, $templates[0]);
$style = $_ if -e $_;
}
$template = $style if $style =~ /\.html?$/;
$re = $opt{'re'} || $QUERY{'re'};
$grepmode = $opt{'grepmode'} || $QUERY{'grepmode'} || 'and';
$grepcase = $opt{'grepcase'} || $QUERY{'grepcase'};
$_ = $re;
&enc_amp_lt_gt;
s/'/'/g; # '
s/"/"/g; # "
$re2 = $_;
$grep_message_ja = $grep_message_en = "" if !$re;
$previewed = 1; # default NO preview
$ENV{'TZ'} = $tz if $tz;
$wenc = $denc || 'sjis'; # databaseに書くときのencoding (不明ならsjis)
$jw = $jcode && $wenc ne 'euc'; # databaseに書くときjcodeで変換するか？
$jd = $jcode && $denc ne 'euc'; # databaseを読むときjcodeで変換するか？
# $styleが決定してないといけない
$styleoptions = &form_templates(&check_templates(@templates)) if $styleselect;
sub check_templates {
local($_, $fn, $i, $mode, @a, @r);
$mode = 1;
foreach (@_) {
&enc_amp_lt_gt;
@a = split(/[ \t]+/, $_);
if ($a[0] eq $style) {
$mode++ while ($mode < @a && $a[$mode] !~ /^\*/);
$mode = 1 if $mode >= @a;
}
}
foreach (@_) {
@a = split(/[ \t]+[*+-]?/, $_);
next if !@a;
$fn = $a[0];
$fn = $template if $fn eq "Table";
$fn = 'notable.html' if $fn eq "No-table";
next if !-e $fn;
for ($i = 1; $i <= $mode; $i++) {
$a[$i] = $a[$i] || $a[$i-1];
}
push(@r, "$a[0]\t$a[$mode]");
}
@r;
}
sub form_templates {
local(@list) = @_;
local($_, @r, @a);
foreach (@list) {
@a = split(/\t/, $_);
$_ = ($a[0] eq $style) ?
"<option value=\"$a[0]\" selected>$a[1]</option>":
"<option value=\"$a[0]\">$a[1]</option>";
push(@r, $_);
}
join("\n", @r);
}
# set cookie
{
local(@a, $expire);
@a = ($name, $style, $tz, $pw, $uemail, $uweb, $ukey, $texttype, $linkurl, $artn);
foreach (@a) {
&urlenc;
}
$_ = join('&', @a);
$expire = &gmtime($^T + $cookietime);
$header_cookie = "Set-Cookie: $cookiename=$_; expires=$expire; \n";
}
sub gmtime {
&tmstr(gmtime($_[0]), " GMT");
}
sub tmstr {
local(@t) = @_;
sprintf("%s, %02d %s %d %02d:%02d:%02d$t[9]",
(Sun,Mon,Tue,Wed,Thu,Fri,Sat)[$t[6]],
$t[3],
(Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec)[$t[4]],
$t[5] + 1900, $t[2], $t[1], $t[0]);
}
$f = $doc;
$f = $wbpw if (!$f && $userpasswd && $pw ne $userpasswd && $pw ne $rootpasswd);
if ($f) {
$f =~ s/[^0-9A-Za-z_.]//g; # ファイル名の汚染除去
&html_out($f);
exit 0;
}
# HTMLファイル出力
sub html_out
{
local($f) = @_;
open(F, $f) || &errprint("Can't open $f! ($!)");
@data = <F>;
close(F);
$tenc = &encoding(@data) || 'sjis';
$jcode = 0 if $tenc eq 'ascii';
$jt = $jcode && $tenc ne 'euc';
&hdrprint();
foreach (@data) {
&jcode'convert(*_, 'euc') if $jcode; # '
&hide_secret;
&subst_var;
&jcode'convert(*_, $tenc) if $jt; # '
print;
}
}
if (!-e $dbdir) {
umask($secure ? 0077 : 0000);
mkdir($dbdir, 0777);
umask($umask);
}
if (!-e $dbfile && !-e "$dbfile.new") {
open(F, ">>$dbfile") || &errprint("Can't create $dbfile! ($!)");
close(F);
}
if ($userpasswd && !-e "$dbdir/index.html" && !-e _) {
open(F, ">>$dbdir/index.html");
close(F);
}
# Read template file and define output style and encoding
# テンプレートを読み込み，出力スタイルやエンコーディングを決定
#
{
local($cache) = "$template.cache";
if (-e "$cache" &&
-M "$cache" < -M $template &&
-M "$cache" < -M $script) {
$_ = "$cache";
/([\w.\/]+)/;
require "./$1";
} else {
@data = ();
open(F, $template) || &errprint("Can't open $template ($!)");
while (<F>) {
&jcode'convert(*_, 'euc') if $jcode; # '
if (/%%fmt_begin%%/ .. /%%fmt_end%%/) {
push(@data, $_); # 出力スタイルの定義部分を@dataに格納
} else {
push(@template, $_);
}
}
close(F);
$tenc = &encoding(@template) || 'sjis';
$jt = $jcode && $tenc ne 'euc';
&fmt_define(@data);
&write_cache("$cache");
}
}
$error_code = "";
sub get_client_info
{
$_ = $ENV{'REMOTE_ADDR'};
$_ = "" if !/\d+\.\d+\.\d+\.\d+/;
$uaddr = $_;
$_ = $ENV{'REMOTE_HOST'} || $_;
$_ = gethostbyaddr(pack('C4',split(/\./,$_)),2) || $_ if /\d+\.\d+\.\d+\.\d+/;
$uhost = $_;
$_ = $ENV{'HTTP_X_FORWARDED_FOR'};
if ($_) {
if (/\d+\.\d+\.\d+\.\d+/ && !&isprivateip($_)) {
$_ = gethostbyaddr(pack('C4',split(/\./,$_)),2);
}
$uhost = "$uhost/$_";
}
}
sub isprivateip
{
local(@ip) = split(/\./, $_[0]);
(($ip[0] == 10) ||
($ip[0] == 172 && $ip[1] >= 16 && $ip[1] <= 31) ||
($ip[0] == 192 && $ip[1] == 168));
}
# ファイルのダウンロード
# $dlfileはEUCに変換しないようにした
if ($dlfile) {
local($fne);
&get_loginfo;
$fne = $dlfile;
&jcode'convert(*fne, 'euc'); # ' キーはEUC
if (!!$passwd{$fne} || $pw =~ $passwd{$fne} || $pw =~ /$rootpasswd/) {
# 本来はここで$dlfileの"./$|"等の汚染を除去しないといけない
{
local(*LOG);
open(LOG, ">dlfile.log");
print LOG "[$dlfile]\n";
close(LOG);
}
&download("$filedir/$dlfile");
} else {
# &html_out($wbpw);
print "Content-type: text/plain\n\n";
print "dlfile: $dlfile\n";
print "pw: $pw\n";
}
&end;
exit 0;
}
# write article
# input
# $str article
# output
# $srcstr & < > encoded JIS
#
if ($in{'file'}) {
local(@a) = &writefile;
$fileinfo = join(' ', @a) if @a;
}
if ($str || $fileinfo) {
&get_client_info;
$_ = &spam_check;
&spam_reject($uaddr, $uhost, $str) if $_;
$str =~ s/\n*$//;
$title = $srctitle;
$srcstr = $str;
$h = $texttype ne 'Pre-formatted';
# convert post article
@data = ();
foreach (split(/\n/, $str)) {
s/^\\/\\\\/;
s/^([.\#])/\\$1/;
push(@data, $_);
}
$_ = join("\n", @data);
&jcode'convert(*_, 'euc') if $jcode; # ' for & < > encoding
s/\r//g;
while ($artsizemax && length($_) > $artsizemax) {
$overflow = 1;
$_ = "" if !s/[^\n ]*$//;
}
if ($texttype ne 'HTML') {
$likehtml = 1 if /<.+>/; # HTMLの疑いがあるか？
&enc_amp_lt_gt;
if ($linkurl) {
# http://www.oersted.co.jp/~yav/ のようなURLをリンクにする
s!(http|https|shttp|ftp|gopher|mailto|news|nntp|telnet|wais|file|prospero|tel)(:[-+\w/~.:@%;?=]*/([-+\w/~.:@%;?=\#&]+)?)!<a href="$1$2">$1$2</a>!g;
# yav@oersted.co.jp のようなメールアドレスをリンクにする
s#([^:\w\-+.])([\w\-+.]+@[\w\-+/.!]*\w)#$1<a href="mailto:$2">$2</a>#g;
}
}
s/\n/<br>\n/g if ($texttype eq 'Plain-text');
$str = $_;
if ($texttype ne 'HTML') {
$_ = $title;
$likehtml = 1 if /<.+>/; # HTMLの疑いがあるか？
&enc_amp_lt_gt;
$title = $_;
}
# check HTML tags in article
if ($texttype eq 'HTML') {
$title = $srctitle;
&jcode'convert(*title, 'euc') if $jcode; # '
if ($htmlck) {
@htmlck_title = &htmlck'report($title, "h2"); # '
@htmlck_result = &htmlck'report($str, "td"); # '
$htmlck_err = @htmlck_title || @htmlck_result;
}
}
if ($srcstr) {
# writing text updated?
$_ = $srcstr;
&jcode'convert(*_, 'euc') if $jcode; # ' for & < >
&enc_amp_lt_gt;
$srcstr = $_; # $srcstr & < > encoded
s/\r//g;
s/\n+$//;
&urlenc;
$npreviewtxt = $_;
$_ = $previewtext;
&urldec;
s/\r//g;
s/\n+$//;
&urlenc;
$opreviewtxt = $_;
$_ = $srctitle;
&jcode'convert(*_, 'euc') if $jcode; # ' for & < >
&enc_amp_lt_gt;
s/'/'/g; # '
s/"/"/g; # "
$srctitle = $_; # $srctitle & < > encoded
s/\r//g;
s/\n+$//;
&urlenc;
$npreviewtitle = $_;
$_ = $previewtitle;
&urldec;
s/\r//g;
s/\n+$//;
&urlenc;
$opreviewtitle = $_;
if ($previewall || $texttype eq "HTML" || $previewtype eq "HTML" || $likehtml) {
$previewed = (($name eq $previewname) &&
($texttype eq $previewtype) &&
($npreviewtitle eq $opreviewtitle) &&
($npreviewtxt eq $opreviewtxt));
}
}
$previewed = 0 if ($htmlck_err || $overflow);
if ($previewed) {
$error_code = &write_article($name, $^T, $h, $uemail, $uweb, 1, $ukey,
"$uaddr $uhost", $uagent, $title,
$fileinfo, $str);
$srctitle = $srcstr = $str = "" if !$error_code;
}
}
# $uaddr $uhost
# $uemail
# $uweb
# $srctitle subject
# $str 本文
sub spam_check
{
local($_, $file);
local($r) = 0;
foreach $file (@nghosts) {
if (-e $file) {
local(@list) = &readlist($file);
foreach ($uaddr, $uhost) {
$r = &matchlist($_, @list);
return $r if $r;
}
}
}
foreach $file (@ngfiles) {
if (-e $file) {
local(@list) = &readlist($file);
foreach ($uemail, $uweb, $srctitle, $str, $ukey, $fileinfo) {
$r = &matchlist($_, @list);
return $r if $r;
}
}
}
0;
}
sub readlist
{
local($file) = @_;
local($_, $re, @list, @src, *F, @nreg, $nreg, $cache);
$cache = "$file.cache";
if (-e $cache && -M $cache < -M $file && open(F, $cache)) {
@list = <F>;
close(F);
chop(@list);
} else {
open(F, $file);
@src = <F>;
close(F);
$_ = join('', @src);
&jcode::convert(*_, 'euc');
foreach (split("\n", $_)) {
push(@nreg, $1) if /^\#\s*<nreg>\s*"(.*)"/;
s/([^\\])#.*$/$1/; # "\#"以外の#以降削除
s/^#.*$//; # 行頭が#の場合もそれ以降削除
s/\s+$//;
next if /^$/;
$re = /^\^/ || /\\/ || /\$$/;
if (!$re) { # 正規表現っぽくないもの
s/([-+.|\(\)\[\]?\/\$])/\\$1/g; # -+|()[]?/$ -> \- \+ ..
s/\*/.*/g; # * -> .* (. -> \. をやった後で)
foreach $nreg (@nreg) {
eval($nreg);
}
}
push(@list, $_);
}
# キャッシュに書き出す
if (open(F, ">$cache")) {
print F join("\n", @list) . "\n";
close(F);
}
}
return @list;
}
sub matchlist
{
local($str, @list) = @_;
local($_, $r);
foreach (@list) {
if ($str =~ /$_/i) {
s/\$/\\\$/;
&jcode'convert(*_, 'jis'); # '
$r = $_;
last;
}
}
$r;
}
sub spam_reject
{
local($adr, $host, $str) = @_;
local(@redirect_url) = ("http://www.mps.gov.cn/cenweb/portal/user/anon/page/policeWeb_HomePage.page",
"http://www.police.go.kr/index.jsp",
"http://www.npa.go.jp/",
"http://www.fbi.gov/",
);
local($redirect_url) = $redirect_url[int(rand(@redirect_url))];
if (0) {
$_ = "$adr;$host;$str";
&jcode'convert(*_, $tenc) if $jt; # '
print "Content-type: text/plain\n";
print "\n";
print "Rejected.\n";
print "$adr $host\n";
&jcode'convert(*str, $tenc) if $jt; # '
print $str;
} else {
$_ = "$adr;$host";
print "Location: $redirect_url?$_\n\n";
}
exit 0;
}
if ($cmd eq "delete") {
&del_articles($opkey, split(/\0/, $target));
}
$page = $opt{'page'} || $QUERY{'page'} || 0;
$next = $page - 1;
$previous = $page + 1;
$nextn = sprintf("%d - %d", $next * $artn + 1, ($next + 1) * $artn);
$prevn = sprintf("%d - %d", $previous * $artn + 1, ($previous + 1) * $artn);
$nbegin = sprintf("%d", $page * $artn + 1);
$nend = sprintf("%d", ($page + 1) * $artn);
$lastscan = $opt{'lastscan'} || $QUERY{'lastscan'} || 0;
if ($re && $lastscan) {
@ar = &get_articles($lastscan, $artn+1, $re); # num +1 for checking end
} else {
@ar = &get_articles($page*$artn, $artn+1, $re); # num +1 for checking end
}
if (@ar > $artn) {
pop(@ar);
$morearticle = 1;
}
$lm = 0;
$_ = '';
if ($lastmodified) {
$lm = -M &dbfile(0);
foreach ($config, $script, $template) {
$lm = -M _ if -e && $lm > -M _;
}
$lm = $^T - 60*60*24 * $lm;
$_ = "Last-modified: " . &gmtime($lm) . "\n";
}
&hdrprint($_);
&get_loginfo;
foreach (@template) {
$last_f = /%%lastpage_begin%%/ .. /%%lastpage_end%%/;
$mnt_f = /%%maintenance_begin%%/ .. /%%maintenance_end%%/;
$preview_f = /%%preview_begin%%/ .. /%%preview_end%%/;
$nopreview_f = /%%nopreview_begin%%/ .. /%%nopreview_end%%/;
$htmlck_f = /%%htmlck_begin%%/ .. /%%htmlck_end%%/;
$error_f = /%%error_begin%%/ .. /%%error_end%%/;
$error_lock_f = /%%error_lock_begin%%/ .. /%%error_lock_end%%/;
$error_write_f = /%%error_write_begin%%/ .. /%%error_write_end%%/;
$error_report_f = /%%error_report_begin%%/ .. /%%error_report_end%%/;
$next_f = /%%next_begin%%/ .. /%%next_end%%/;
$previous_f = /%%previous_begin%%/ .. /%%previous_end%%/;
$styleselect_f = /%%styleselect_begin%%/ .. /%%styleselect_end%%/;
$cgilib_f = /%%cgilib_begin%%/ .. /%%cgilib_end%%/;
next if ($last_f && $page);
next if ($mnt_f && $pw ne $rootpasswd);
next if ($preview_f && ($previewed || $htmlck_err));
next if ($nopreview_f && !$previewed);
next if ($htmlck_f && !$htmlck_err);
next if ($error_lock_f && $error_code !~ /e_lock/);
next if ($error_write_f && $error_code !~ /e_write/);
next if ($error_report_f && (!$error_code || $error_code =~ /e_lock/));
next if ($error_f && !$error_code);
next if ($next_f && !$page);
next if ($previous_f && !$morearticle);
next if ($styleselect_f && !$styleselect);
next if ($cgilib_f && !$cgilib);
$_ = $styleoptions if /%%styleoptions%%/; # $styleoptionsもsubst_varする
&subst_var;
s#<option>($style</option>)#<option selected>$1#i if $style;
s#<option>($tz</option>)#<option selected>$1#i if $tz;
s#<option>($texttype</option>)#<option selected>$1#i if $texttype;
s#<(option value="$style")>#<$1 selected>#i if $style;
s#<(option value="$tz")>#<$1 selected>#i if $tz;
s#<(option value="$texttype")>#<$1 selected>#i if $texttype;
s#<(input type=radio name=type value="$texttype")>#<$1 checked>#i if $texttype;
s#(<input .* name=linkurl) (.*>)#$1 checked $2#i if $linkurl;
s#<(input type=radio name=grepmode value="$grepmode")>#<$1 checked>#i;
s#<(input type=checkbox name=grepcase value="sensitive")>#<$1 checked>#i if $grepcase;
if (/%%preview%%/ && $str) {
&print_articles(join("\n", $name, $^T, $$,
$texttype ne "Pre-formatted",
$uemail, $uweb, 99999, $ukey,
"$uaddr $uhost", $uagent,
$title, $fileinfo, $str));
}
&debuginfo if ($debugmode && /%%debuginfo%%/);
&print_articles(@ar) if (/%%articles%%/ && !$htmlck_err);
&report_errors(@htmlck_title) if (/%%diagnostics%%/ && @htmlck_title);
&report_errors(@htmlck_result) if (/%%diagnostics%%/ && @htmlck_result);
next if /^\n$/;
next if /%%.*%%/;
&jcode'convert(*_, $tenc) if $jt; # '
print;
}
exit 0;
###
sub subst_var {
$_ = $stylesheet if /%%stylesheet%%/;
s/%head_title%/$head_title/go;
s/%body_title_en%/$body_title_en/go;
s/%body_title_ja%/$body_title_ja/go;
s/%body_title_i%/$body_title_i/go;
s/%body_title%/$body_title/go;
s/%body_top_message%/$body_top_message/go;
s/%body_post_message%/$body_post_message/go;
s/%body_bottom_message%/$body_bottom_message/go;
s/%body_lastpage_message_en%/$body_lastpage_message_en/go;
s/%body_lastpage_message_ja%/$body_lastpage_message_ja/go;
s/%body_lastpage_message%/$body_lastpage_message/go;
s/%str_back_en%/$str_back_en/go;
s/%str_back_i%/$str_back_i/go;
s/%str_back%/$str_back/go;
s/%str_help_en%/$str_help_en/go;
s/%str_help%/$str_help/go;
s/%help_body_title_ja%/$help_body_title_ja/go;
s/%help_body_title_en%/$help_body_title_en/go;
s/%myname%/$myname/go;
s/%enctype%/$enctype/go;
s/%version%/$version/go;
s/%yav%/$yav/go;
s/%yavemail%/$yavemail/go;
s/%previewtext%/$npreviewtxt/go;
s/%previewtitle%/$npreviewtitle/go;
s/%previewtype%/$texttype/go;
s/%previewname%/$name/go;
s/%srctitle%/$srctitle/go;
s/%srcstr%/$srcstr/go;
s/%uname%/$name/go;
s/%fileinfo%/$fileinfo/go;
s/%error_code%/$error_code/go;
s/%page%/$page/go;
s/%next%/$next/go;
s/%previous%/$previous/go;
s/%nextn%/$nextn/go;
s/%prevn%/$prevn/go;
s/%nbegin%/$nbegin/go;
s/%nend%/$nend/go;
s/%author%/$author/go;
s/%email%/$email/go;
s/%pw%/$pw/go;
s/%userpasswd%/$userpasswd/go;
s/%top%/$top/go;
s/%tope%/$tope/go;
s/%topi%/$topi/go;
s/%artsizemax%/$artsizemaxC/go;
s/%artsizemaxK%/$artsizemaxK/go;
s/%artn%/$artn/go;
s/%uemail%/$uemail/go;
s/%uweb%/$uweb/go;
s/%ukey%/$ukey/go;
s/%dbfilemax%/$dbfilemax/go;
s/%dbsizemax%/$dbsizemax/go;
s/%maxdata%/$maxdataC/go;
s/%maxdataK%/$maxdataK/go;
s/%grep_message_en%/$grep_message_en/go;
s/%grep_message_ja%/$grep_message_ja/go;
s/%lastscan%/$lastscan/go;
s/%grepmode%/$grepmode/go;
s/%grepcase%/$grepcase/go;
s/%re%/$re2/go;
s/%style%/$style/go;
}
###
sub fmt_define {
foreach (@_) {
&subst_var;
push(@fmt_head, $_) if /%%head_begin%%/ .. /%%head_end%%/;
push(@fmt_body, $_) if /%%body_begin%%/ .. /%%body_end%%/;
push(@fmt_tail, $_) if /%%tail_begin%%/ .. /%%tail_end%%/;
push(@fmt_month, $_) if /%%month_begin%%/ .. /%%month_end%%/;
push(@fmt_week, $_) if /%%week_begin%%/ .. /%%week_end%%/;
push(@fmt_day, $_) if /%%day_begin%%/ .. /%%day_end%%/;
push(@fmt_hour, $_) if /%%hour_begin%%/ .. /%%hour_end%%/;
push(@fmt_min, $_) if /%%min_begin%%/ .. /%%min_end%%/;
push(@fmt_sec, $_) if /%%sec_begin%%/ .. /%%sec_end%%/;
push(@fmt_ampm, $_) if /%%ampm_begin%%/ .. /%%ampm_end%%/;
push(@fmt_mail, $_) if /%%mail_begin%%/ .. /%%mail_end%%/;
push(@fmt_file, $_) if /%%file_begin%%/ .. /%%file_end%%/;
}
# /%%*_begin%%/ と /%%*_end%%/ の行を削除
shift(@fmt_head); pop(@fmt_head);
shift(@fmt_body); pop(@fmt_body);
shift(@fmt_tail); pop(@fmt_tail);
shift(@fmt_month); pop(@fmt_month);
shift(@fmt_week); pop(@fmt_week);
shift(@fmt_day); pop(@fmt_day);
shift(@fmt_hour); pop(@fmt_hour);
shift(@fmt_min); pop(@fmt_min);
shift(@fmt_sec); pop(@fmt_sec);
shift(@fmt_ampm); pop(@fmt_ampm);
shift(@fmt_mail); pop(@fmt_mail);
shift(@fmt_file); pop(@fmt_file);
@fmt_month = split(/[,\n]+/, join('', @fmt_month));
@fmt_week = split(/[,\n]+/, join('', @fmt_week));
@fmt_day = split(/[,\n]+/, join('', @fmt_day));
@fmt_hour = split(/[,\n]+/, join('', @fmt_hour));
@fmt_min = split(/[,\n]+/, join('', @fmt_min));
@fmt_sec = split(/[,\n]+/, join('', @fmt_sec));
@fmt_ampm = split(/[,\n]+/, join('', @fmt_ampm));
@fmt_month = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec) unless @fmt_month;
@fmt_week = (Sun,Mon,Tue,Wed,Thu,Fri,Sat) unless @fmt_week;
@fmt_day = (0 .. 31) unless @fmt_day;
@fmt_hour = (0 .. 23) unless @fmt_hour;
@fmt_min = (0 .. 59) unless @fmt_min;
@fmt_sec = (0 .. 59) unless @fmt_sec;
@fmt_ampm = ('am','pm') unless @fmt_ampm;
@fmt_file = split(/[,\n]+/, join('', @fmt_file));
foreach (@fmt_file) {
$fmt_file{$_} = 1;
}
}
###
sub print_articles {
local(@ar) = @_;
local($_);
$_ = join('', @fmt_head);
&jcode'convert(*_, $tenc) if $jt; # '
print;
foreach (@ar) {
&print_article(split(/\n/, $_, 13));
}
$_ = join('', @fmt_tail);
&jcode'convert(*_, $tenc) if $jt; # '
print;
}
sub get_articles {
local($from, $num, $re) = @_;
local($_, $fn, $a, @s, @r, %h);
if ($re) {
$_ = $re;
if ($jcode) {
&jcode'convert(*_, 'euc'); # '
&z2h;
}
y/A-Z/a-z/ if !$grepcase;
$re = $_;
}
$lastscan = 0;
for ($fn = 0; open(F, &dbfile($fn)); $fn++) {
%h = @s = ();
foreach (<F>) {
next if /^#/; # '#'で始まる行はコメントとして無視
s/\r?\n$//; # $dbfile行末が\r\nにされた場合対策
if ($from) {
if ($_ eq ".") {
--$from;
$lastscan++;
}
next;
}
last if !$num;
if ($_ eq ".") {
$lastscan++;
if (!$re || &match($re, join("\n", (@h{'n','s'}, join("", @s))))) {
--$num;
$_ = join("\n", (@h{'n','t','i','h','m','w','r','k','H','A','s','f'}, join("", @s)));
&jcode'convert(*_, 'euc') if $jd; # '
push(@r, $_);
}
%h = @s = ();
} elsif (/^\./) {
s/^\.h$/.h 1/;
($_, $a) = split(/ /, $_, 2);
s/^\.//;
$h{$_} = $a;
} else {
push(@s, "$_\n");
}
}
close(F);
}
@r;
}
# 記事に検索する言葉が含まれているか調べる
sub match {
local($re, $_) = @_;
local($a, $r);
s/<[^>]*>//g; # HTMLタグを削除
&jcode'convert(*_, 'euc') if $jd; # '
&dec_amp_lt_gt; # URLエンコードされてる&<>を元に戻す
&z2h if $jcode; # 全角文字を半角文字に変換
y/A-Z/a-z/ if !$grepcase; # 大文字を小文字に変換
$a = $_;
$r = 0; # 最初は含まれていない
if ($grepmode eq 'and') {
foreach (split(/\s+/, $re)) {
$r = index($a, $_) >= 0;
last if !$r; # 含まれてないのがひとつでもあったら終了
}
} elsif ($grepmode eq 'or') {
foreach (split(/\s+/, $re)) {
$r = index($a, $_) >= 0;
last if $r; # 含まれてるのがひとつでもあったら終了
}
} else {
$r = /$re/;
}
$r; # 含まれてるかどうかを返す
}
sub del_articles {
local($key, @dellist) = @_;
local($_, $i, $a, $f, @data, @r, $n, $num, @newdata, %h);
$key = $key || '*';
if (!&lock($dbfile, 30)) {
return 0;
}
$num = 0;
for ($i = 0; $f = &dbfile($i), -e $f; $i++) {
open(F, $f) || last;
@data = <F>;
close(F);
%h = @newdata = @r = ();
$n = 0;
foreach (@data) {
push(@r, $_);
s/\r?\n$//; # $dbfile行末が\r\nにされた場合対策
if ($_ eq ".") {
if ($h{'t'} && $h{'i'} &&
grep(/^$h{'t'}\.$h{'i'}$/, @dellist) &&
($key eq $rootpasswd || $key eq $h{'k'})) {
$n++;
@r = ();
&del_file($h{'f'}, "$h{'t'}\.$h{'i'}");
}
push(@newdata, @r);
%h = @r = ();
} elsif (/^\./) {
s/^\.h$/.h 1/;
($_, $a) = split(/ /, $_, 2);
s/^\.//;
$h{$_} = $a;
}
}
if ($n) {
if (open(F, ">$f.new")) {
$n = 0 if !print F @newdata;
close(F);
rename("$f.new", "$f") if $n;
} else {
$n = 0;
}
}
$num += $n;
}
&unlock($dbfile);
$num;
}
sub dbfile {
$_[0] ? sprintf("$dbfile%04d", $_[0]) : $dbfile;
}
###
sub print_article {
local($name, $time, $pid, $h, $mail, $web, $sr, $k, $addr, $agent, $title,
$fileinfo, $str) = @_;
local($host);
local($_, $tt, @form, @tmp);
local($SS,$MM,$HH,$dd,$mm,$yy,$ww,$yday,$isdst);
local($day, $hh, $am, $month, $hour, $min, $sec, $tzz);
local($mname, $wname, $mail2);
$tt = '(unknown)';
if ($time) {
($SS,$MM,$HH,$dd,$mm,$yy,$ww,$yday,$isdst) = localtime($time);
$yy += 1900;
$month = $fmt_month[$mm];
$mm += 1;
$ww = $fmt_week[$ww];
$day = $fmt_day[$dd];
$hour = $fmt_hour[$HH];
if ($HH < 12) {
$am = $fmt_ampm[0];
$hh = $HH;
} else {
$am = $fmt_ampm[1];
$hh = $HH - 12;
}
$hh = 12 if !$hh;
$min = $fmt_min[$MM];
$sec = $fmt_sec[$SS];
$tt = sprintf("$yy/%02d/%02d $ww %2d:%02d %s", $mm, $dd, $HH, $MM, $ENV{'TZ'});
}
$_ = $name || '(anonymous)';
&enc_amp_lt_gt;
$name = $_;
$mname = $mail ? "<a href=\"mailto:$mail\">$_</a>" : $_;
$wname = $web ? "<a href=\"$web\">$_</a>" : $mname;
$mail2 = $mail ? $fmt_mail[0] : "";
$_ = $addr;
&enc_amp_lt_gt;
($addr, $host) = split(/ /);
$_ = $agent;
&enc_amp_lt_gt;
$agent = $_;
local($file, $img, $imgfile, $imgalt);
local($filename, $filesize, $filetype, $width, $height) = split(/ /, $fileinfo);
$imgalt = "$filetype $filesize bytes";
if ($height) {
$imgalt = "$filetype ${width}x$height $filesize bytes";
local($rw, $rh) = &imgrate($width, $height);
$img = qq!<img src="$filedir/$filename" width=$rw height=$rh alt="$imgalt">!;
if ($rw != $width || $rh != $height) { # 縮小表示？
$img = qq!<a href="$filedir/$filename" target=blank>$img</a>!;
}
}
foreach (split(/\n/, $str)) {
s/^\\//;
push(@tmp, $_);
}
$_ = join("\n", @tmp);
if ($filename) {
local($n, $fn);
local($tmp) = $_;
$_ = $filename;
&urldec;
$fn = $_;
if ($secure && $userpasswd) {
local($url, $fne);
$url = $fn;
$url =~ s#([^\w\-+./~])#"%" . unpack("H2",$1)#ge;
$fne = $fn;
&jcode'convert(*fne, 'euc'); # ' キーはEUC
if (!$passwd{$fne} || $pw =~ /$passwd{$fne}/ || $pw =~ /$rootpasswd/) {
$file = "<a href=\"$myname/$url?pw=$pw&fn=$url\">$fn $imgalt</a>";
} else {
$file = "(not available)";
}
} else {
$file = "<a href=\"$filedir/$filename\">$fn $imgalt</a>";
}
$img = $file if $fmt_file{'no-image'};
$_ = $tmp;
$n = s#%file%#$filedir/$filename#g;
$n += s/%size%/$filesize/g;
if ($img) {
$n += s/%width%/$width/g;
$n += s/%height%/$height/g;
$n += s/%img%/$img/g;
$imgfile = $img;
} else {
$imgfile = $file;
}
$imgfile = $file = '' if $n;
}
$str = $_;
$tzz = $tz || $ENV{'TZ'} || "JST-9";
@form = @fmt_body;
foreach (@form) {
next if (/%%pre_begin%%/ .. /%%pre_end%%/) && $h;
next if (/%%html_begin%%/ .. /%%html_end%%/) && !$h;
next if /%%.*%%/;
s/%mail2%/$mail2/g; # %mail% contained in $mail2
s/%name%/$name/g;
s/%mname%/$mname/g;
s/%wname%/$wname/g;
s/%date%/$tt/g;
s/%title%/$title/g;
s/%mail%/$mail/g;
s/%web%/$web/g;
s/%sr%/$sr/g;
s/%time%/$time/g;
s/%pid%/$pid/g;
s/%yy%/$yy/g;
s/%month%/$month/g;
s/%mm%/$mm/g;
s/%dd%/$dd/g;
s/%day%/$day/g;
s/%ww%/$ww/g;
s/%hour%/$hour/g;
s/%hh%/$hh/g;
s/%am%/$am/g;
s/%HH%/$HH/g;
s/%MM%/$MM/g;
s/%min%/$min/g;
s/%SS%/$SS/g;
s/%sec%/$sec/g;
s/%tz%/$tzz/go;
if ($remoteinfo) {
s/%host%/$host/g;
s/%addr%/$addr/g;
s/%agent%/$agent/g;
} else {
s/%host%//g;
s/%addr%//g;
s/%agent%//g;
}
s/%file%/$file/g;
s/%imgfile%/$imgfile/g;
s/%str%/$str/g; # 本文の %なんとか% 置換を避けるため最後に
0 while s#<([\w]+)[^<>]*> *</\1>##g; # delete <foo> </foo>
&jcode'convert(*_, $tenc) if $jt; # '
print;
}
}
# 画像が$maximgwidth,$maximgheight以下になるようなサイズを求める
sub imgrate {
local($w, $h) = @_;
local($r) = 1;
$r /= 2 while $maximgwidth > 0 && $w*$r > $maximgwidth;
$r /= 2 while $maximgheight > 0 && $h*$r > $maximgheight;
(int($w * $r), int($h * $r));
}
###
sub write_article {
local($name, $time, $h, $mail, $web, $sr, $k, $addr, $agent, $title,
$fileinfo, $str) = @_;
local($_, $new, $r, @data, *F, $chlog, $same);
$mail =~ s/[<>]//g;
$_ = $web;
s/[<>]//g;
if ($_ && !/^http:/) {
$_ = "//$_" if !/^\//;
$_ = "http:$_";
}
$web = $_;
$name = '(anonymous)' unless $name;
$_ = "";
$_ .= ".n $name\n";
$_ .= ".t $time\n";
$_ .= ".i $$\n";
$_ .= ".m $mail\n" if $mail;
$_ .= ".w $web\n" if $web;
$k = $k || '*';
$_ .= ".k $k\n";
$_ .= ".H $addr\n" if $addr;
$_ .= ".A $agent\n" if $agent;
$_ .= ".h\n" if $h;
$_ .= ".s $title\n" if $title;
$_ .= ".f $fileinfo\n" if $fileinfo;
$new = "$_$str\n.\n";
&jcode'convert(*new, $wenc) if $jw; # '
return "e_lock" if !&lock($dbfile, 30); # ロックできなかった
if ($sr) {
@data = &get_articles(0, 1);
@data = split(/\n/, $data[0], 13);
$sr = $data[6] + 1;
$new = ".r $sr\n$new";
# 二重投稿のチェック
# 0 1 2 3 4 5 6 7 8 9 10 11
# {'n','t','i','h','m','w','r','k','H','A','s','f'}
$same = (($name eq $data[0]) &&
($k eq $data[7]) &&
($addr eq $data[8]) &&
($agent eq $data[9]) &&
($title eq $data[10]) &&
("$str\n" eq $data[12]));
$r = "e_double_post" if $same;
}
@data = ();
$chlog = $dbsizemax && length($new) + -s $dbfile > $dbsizemax;
if (!$chlog) {
if (open(F, "$dbfile")) {
@data = <F>; # 全部読み込む
close(F);
} else {
$r = "e_open org";
}
}
if (!$r) {
if (open(F, ">$dbfile.new")) {
$r = "e_write" if !print F $new, @data;
close(F);
} else {
$r = "e_open new";
}
if (!$r) {
if ($chlog && !&rename_db(0)) {
$r = "e_rename_0";
} else {
if (!rename("$dbfile.new", "$dbfile")) {
$r = "e_rename_new";
}
}
}
}
&filelog_ref($fileinfo, "$time.$$") if $fileinfo;
&unlock($dbfile);
$r;
}
sub rename_db {
local($n) = @_;
local($src, $dst, $r);
$src = &dbfile($n);
$dst = &dbfile($n+1);
$r = 1; # 1: Success
$r = &rename_db($n+1) if (!$dbfilemax || $n+1 < $dbfilemax-1) && -e $dst;
$r = rename($src, $dst) if $r && -e $src;
$r;
}
# flockを使わないファイルのロック機構
# ロックをかける
# 他の誰かがロックしてても，$maxtimeの間は挑戦しつづける．
# lockfileを作成するディレクトリが書き込み許可じゃないと
# エラーが発生して，ロックできません．
sub lock {
local($f, $maxtime) = @_;
$symlink = (eval 'symlink("", "");', $@ eq '') if !defined($symlink);
sleep(1) until ($symlink ? symlink("p$$","$f.lck") : link($f,"$f.lck")) || !--$maxtime;
$maxtime;
}
# ロックを解除する
# lockfileのあるディレクトリが書き込み許可じゃないと
# エラーが発生して，ロック解除できません．
sub unlock {
local($f) = @_;
unlink("$f.lck");
}
sub debuginfo {
local($_, @files);
$_ = "<hr>
<h2>Variables</h2>
<pre>
header_cookie: $header_cookie
style [$style] tz [$tz] linkurl [$linkurl]
HTTP_COOKIE: [$ENV{'HTTP_COOKIE'}]
HTTP_USER_AGENT: [$ENV{'HTTP_USER_AGENT'}]
QUERY_STRING: [$ENV{'QUERY_STRING'}]
Target encoding: [$tenc]
cmd: [$cmd]
opkey: [$opkey]
target: [$target]
debugstr: [$debugstr]
next: [$next]
previouts: [$previous]
</pre>
";
&jcode'convert(*_, $tenc) if $jt; # '
print;
@files = ($config, $script, $template, $wbpw, $htmlck, $jcode);
foreach (@files) {
&dumpfile($_) if -r $_;
}
print "<hr>";
}
sub dumpfile {
local($file) = @_;
local($_);
if (open(F, $file)) {
print "<hr><h2>$file</h2><pre>";
while (<F>) {
&hide_secret;
&jcode'convert(*_, 'euc') if $jcode; # ' for & < > in jis encoding
&enc_amp_lt_gt;
&jcode'convert(*_, $tenc) if $jt; # '
print;
}
close(F);
print "</pre>";
} else {
print "<hr><code>$file<code> not exist.<br>\n";
}
}
sub hide_secret {
s/(["'])\w*(['"].*\s+#\s*<secret>)/$1xxx$2/;
}
########
sub report_errors {
local(@list) = @_;
local($_, $f);
foreach (@list) {
($f, $_) = split(//, $_, 2);
&enc_amp_lt_gt;
$_ = "<u><font color=red>$_</font></u>" if $f;
}
$_ = join('', @list);
&jcode'convert(*_, $tenc) if $jt; # '
print "<pre>$_</pre>";
}
#######
# HTML文書に記述されたcharacter set encodingをとりだす
sub encoding {
local($r);
foreach (@_) {
if (/<meta http-equiv=.* content=.* charset=.*>/i) {
$r = 'jis' if /iso-2022-jp/i;
$r = 'sjis' if /Shift_JIS/i;
$r = 'euc' if /euc-jp/i;
$r = 'ascii' if /ascii/i;
last;
}
}
$r;
}
# 全角文字を半角文字に変換
# $_がEUCでエンコードされてるのを期待している
sub z2h
{
if (!$z2h_from) {
$z2h_from = '−！”＃＄％＆’（）＊＋．／０-９：；＜＝＞？'
. '＠Ａ-Ｚ［￥］＾＿｀ａ-ｚ｛｜｝〜';
$z2h_to = '-!"#$%&\'()*+./0-9:;<=>?'
. '@A-Z[\\]^_`a-z{|}~';
&jcode'convert(*z2h_from, 'euc'); # '
}
&jcode'tr(*_, $z2h_from, $z2h_to); # '
}
sub enc_amp_lt_gt {
s/&/&/g;
s/</</g;
s/>/>/g;
}
sub dec_amp_lt_gt {
s/</</g;
s/>/>/g;
s/&/&/g;
}
sub urldec {
s/\+/ /g;
s/%([0-9A-Fa-f][0-9A-Fa-f])/pack("C", hex($1))/ge;
}
sub urlenc {
s/(\W)/"%" . unpack("H2",$1)/ge;
}
sub urlenc2 {
local($_) = @_;
s/([^\w.])/"%" . unpack("H2",$1)/ge;
$_;
}
# HTTPヘッダの出力
# $header_printed 既にヘッダを出力してるか
# $tenc 出力する文字エンコーディング
# $gzip gzipのpath 設定されてたら以降STDOUTはgzipで圧縮
sub hdrprint {
if (!$header_printed) {
local($z, $c, $enc);
$c = "; charset=iso-2022-jp" if $tenc eq 'jis';
$c = "; charset=Shift_JIS" if $tenc eq 'sjis';
$c = "; charset=euc-jp" if $tenc eq 'euc';
$c = "; charset=ASCII" if $tenc eq 'ascii';
$z = $ENV{'HTTP_ACCEPT_ENCODING'} =~ /gzip/ && -e $gzip;
$enc = "Content-encoding: gzip\n" if $z;
print $header_cookie;
print "Content-type: text/html$c\n";
print "$_[0]" if $_[0];
print "$enc" if $enc;
print "\n";
open(STDOUT,"| $gzip -1 -f") if $z;
$header_printed = 1;
}
}
sub errprint {
&hdrprint;
print "<html><body><h1><code>", __FILE__, "</code> error report</h1>";
print "<font color=red><strong>";
print "@_";
print "</strong></font></body></html>\n";
exit 0;
}
sub writefile
{
local($buf, @log, *LOG, *SRC, *DST);
local($cutmacbin, $i, $left, %a);
local($dir) = $filedir;
local(@result);
grep(/filename="(.*)"/ && ($i = $1), @in);
$_ = $i;
if ($_ eq '') {
unlink($in{'file'});
} else {
open(LOG, "+<$logfile");
flock(LOG, 2); # logfile exclusive lock!
@log = <LOG>;
$i = "upfile: $_\n";
&jcode'convert(*i, $logenc) if $jcode; # '
push(@log, $i);
s#.*[:/\\]##; # C:\TMP\file.lzh -> file.lzh
$_ = "#$_#" if "$dir/$_" eq "$logfile";
if ($_) {
if ($rename_old) {
&rename_old("$_");
} else {
# file.lzh -> file_.lzh
$_ = /(.*)(\..*)/ ? "$1_$2" : "${_}_" while -e "$dir/$_";
}
push(@log, "svfile: " . &urlenc2($_) . "\n");
@result = (&urlenc2($_));
push(@result, -s($in{'file'}));
$cutmacbin = 0;
if ($ftype) {
%a = &ftype'check($in{'file'}); # '
push(@log, "file-type: $a{'type'}/$a{'subtype'} $a{'width'} $a{'height'} $a{'depth'} $a{'ver'} $a{'macbin'} $a{'datasize'}\n");
$cutmacbin = 1 if $a{'macbin'};
$cutmacbin = 0 if $in{'macbin'};
push(@result, "$a{'type'}/$a{'subtype'}", $a{'width'}, $a{'height'});
}
if ($cutmacbin) {
if (open(SRC, $in{'file'})) {
if (open(DST, ">$dir/$_")) {
read(SRC, $buf, 128); # Skip Macbin 128 bytes
for ($left = $a{'datasize'}; $left > 0; $left -= $i) {
$i = $left > 65536 ? 65536 : $left;
$i = read(SRC, $buf, $i);
last if !$i; # Read error?
if (!print DST $buf) {
push(@log, "write $dir/$_ error!\n");
last;
}
}
close(DST);
} else {
push(@log, "open $dir/$_ failed!\n");
}
close(SRC);
} else {
push(@log, "open $in{'file'} failed!\n");
}
unlink($in{'file'});
} else {
if (!rename($in{'file'}, "$dir/$_")) {
push(@log, "rename $in{'file'} $dir/$_ failed!\n");
}
}
chmod(0644, "$dir/$_");
}
push(@log, "date: " . &tmstr(localtime($^T)) . "\n");
push(@log, "REMOTE_HOST: $ENV{'REMOTE_HOST'}\n");
push(@log, "HTTP_USER_AGENT: $ENV{'HTTP_USER_AGENT'}\n");
if ($secure && $pw) {
push(@log, "passwd: $pw\n");
}
while (($key, $val) = each %in) {
next if !$key;
next if ($key =~ /^pw$/);
next if grep(/^$key$/, @importlist);
$_ = "$key: $val";
&jcode'convert(*_, 'sjis') if $jcode; # '
&enc_amp_lt_gt;
&jcode'convert(*_, $logenc) if $jcode; # '
push(@log, "$_\n");
}
push(@log, "--------\n");
seek(LOG, 0, 0);
print LOG @log;
close(LOG);
}
@result;
}
sub rename_old
{
local($_) = @_;
local($fn, $old);
if (-e "$dir/$_") {
$fn = $_;
$_ = /(.*)(\..*)/ ? "$1~$2" : "$_~";
&rename_old($_);
if (!rename("$dir/$fn", "$dir/$_")) {
push(@log, "rename $fn $_ failed!\n");
}
$old = $_;
foreach (@log) {
if (s/svfile: $fn\n/svfile: $old\n/) {
$_ = "rename: $fn $old ($date)\n$_";
}
}
}
}
sub filelog_ref {
local($fileinfo, $id) = @_;
local(@log, *LOG);
local($_, $f);
local($filename) = split(/ /, $fileinfo);
$f = $filename;
$f =~ s/(\W)/\\$1/g;
open(LOG, "+<$logfile");
flock(LOG, 2); # logfile exclusive lock!
local($/) = ("\n--------\n");
@log = <LOG>;
foreach (@log) {
next if /^\n*$/;
if (grep(/^svfile: $f$/, split(/\n/))) {
s/^/ref: $id\n/;
}
}
seek(LOG, 0, 0);
print LOG @log;
close(LOG);
}
sub del_file {
local($fileinfo, $id) = @_;
local(@log, *LOG);
local($_, $f);
local($filename) = split(/ /, $fileinfo);
$f = $filename;
$f =~ s/(\W)/\\$1/g;
open(LOG, "+<$logfile");
flock(LOG, 2); # logfile exclusive lock!
local($/) = ("\n--------\n");
@log = <LOG>;
foreach (@log) {
next if /^\n*$/;
if (grep(/^svfile: $f$/, split(/\n/))) {
$_ = '';
}
}
seek(LOG, 0, 0);
truncate(LOG, 0);
print LOG @log;
close(LOG);
$fileinfo =~ m/^(\S+)\s/;
$_ = $1;
&urldec;
unlink("$filedir/$_");
}
sub write_cache {
local($file) = @_;
local(@varlist) =
('$tenc', '$jt', '@template',
'@fmt_head',
'@fmt_body',
'@fmt_tail',
'@fmt_mail',
'@fmt_month',
'@fmt_week',
'@fmt_day',
'@fmt_hour',
'@fmt_min',
'@fmt_sec',
'@fmt_ampm',
'@fmt_month',
'@fmt_week',
'@fmt_day',
'@fmt_hour',
'@fmt_min',
'@fmt_sec',
'@fmt_ampm',
'%fmt_file',
);
write_cache_sub($file, @varlist);
}
sub write_cache_sub
{
local($_, @varlist) = @_;
local($file, $a, $handle, *F);
/([\w.\/]+)/;
$file = $1;
open(F, ">$file");
$handle = select(F);
print "#!perl\n# $file - wb configuration cache\n";
foreach (@varlist) {
print "$_ = ";
$a = !/^\$/;
print "(\n" if $a;
foreach (eval($_)) {
s/'/\\'/g;
print "'$_'";
print ",\n" if $a;
}
print ")" if $a;
print ";\n";
}
print "1;\n";
select($handle);
close(F);
}
# logfileから %note, %passwd に値を設定する
sub get_loginfo
{
local(@log);
local(*F);
open(F, $logfile);
flock(F, 1); # logfile shared lock!
@log = <F>;
close(F);
foreach (@log) {
chop;
$n = "" if /^--/;
if (s/^svfile: //) {
&urldec;
$n = $_;
&jcode'convert(*n, 'euc'); # ' キーはEUC
}
if (s/^note: //) {
$note{$n} = $_;
} elsif (s/^passwd: //) {
$passwd{$n} = $_;
}
}
}
sub download
{
local($fn) = @_;
local($filename, $buf, $type, $len);
local(*F);
if ($fn eq $logfile) {
$type = "text/plain";
} else {
local(%a);
%a = &ftype'check($fn) if $ftype; # '
if ($a{'type'}) {
$type = "$a{'type'}/$a{'subtype'}";
} else {
$type = "application/octet-stream";
}
}
$len = -s $fn;
$filename = $fn;
$filename =~ s#^.*/##;
{
local(*LOG);
open(LOG, ">ftype.log");
print LOG "[$fn] [$type] ($len) ----------------\n";
close(LOG);
}
print "Content-Type: $type\n";
print "Content-Disposition: inline; filename=$filename\n";
print "Content-Length: $len\n" if $len;
print "Last-Modified: ", &gmtime($^T - 60*60*24 * -M $fn), "\n";
print "\n";
open(F, "$fn");
$| = 1 if $txbps;
if ($fn eq $logfile) {
while (<F>) {
if ($pw !~ /$rootpasswd/) {
s/^REMOTE_HOST: .*/REMOTE_HOST: ???/;
s/^passwd: .*/passwd: ???/;
}
print "$_";
}
} else {
$len = $txbps || 32768; # &calc_txspeed;
while (read(F, $buf, $len)) {
print $buf;
if ($txbps) {
sleep(1); # for Band-width limit
# @clients = &get_clients(0);
# $len = $txbps || 32768; # &calc_txspeed;
}
}
}
close(F);
}
# Local Variables:
# mode:perl
# End:
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html lang=ja>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=Shift_JIS">
<!-- 美乳 -->
<title>%head_title%</title>
<meta name="description" content="%author%'s %head_title%">
<meta name="Author" content="%author%">
<link rev="MADE" href="mailto:%email%">
<link rel="PREV" href="%top%">
<meta http-equiv="Content-Style-Type" content="text/css">
<style type="text/css">
<!--
body {
background-color: #ffffcc;
background-image: url(bg.gif);
color: black;
}
a:link { color: blue; }
a:visited { color: purple; }
a:active { color: red; }
.errormessage {
text-align: center;
color: red;
background-color: white;
}
.artable {
margin: 0 0 0.4em 0;
}
.headline {
background-color: #bbffdd;
border-width: 1 1 0 1;
border-color: #bbffdd;
}
.serial { color: green; }
.subject {
font-size: 1.3em;
font-weight: bold;
}
.name {
color: navy;
}
.date {
font-family: monospace;
font-size: 0.75em;
vertical-align: baseline;
color: maroon;
}
.article {
color: navy;
background-color: #f0f8ff; /* aliceblue */
border-width: 0 1 0 1;
border-color: #f0f8ff;
}
.remoteinfo {
text-align: right;
color: #aa4488;
font-size: 0.75em;
}
.styleselect { font-size: 0.9em;}
.inputfield { }
.optionalinput {
font-size: 0.75em;
color: gray;
}
#inputtitle {
font-size: 1em;
}
.preformatted {
font-family: monospace;
}
blockquote {
color: green;
}
//-->
</style>
<!-- %%stylesheet%% -->
</head>
<body bgcolor="#ffffcc" background="bg.gif"
text=black link=blue vlink=purple alink=red>
<h1 align=center>%body_title%</h1>
%body_top_message%
<p><code>%%lastpage_begin%% ========</code></p>
%body_lastpage_message%
<p><code>%%lastpage_end%% ========</code></p>
<a href="%tope%">%str_back_en%</a><br>
<a href="%top%">%str_back%</a>
<p><code>%%styleselect_begin%% ========</code></p>
<form method="POST" action="%myname%" class="styleselect">
<input type=hidden name=pw value="%pw%">
Style:<select name=style>
<option>%%styleoptions%%</option>
</select>
Timezone:<select name=tz>
<option>JST-9</option>
<option>EST5EDT</option>
<option>CST6CDT</option>
<option>MST7MDT</option>
<option>PST8PDT</option>
<option>AST9ADT</option>
<option>HST10HDT</option>
<option>EET-10EETDT</option>
<option>WAUST-8WAUDT</option>
<option>GMT-12</option>
<option>GMT-11</option>
<option>GMT-10</option>
<option>GMT-9</option>
<option>GMT-8</option>
<option>GMT-7</option>
<option>GMT-6</option>
<option>GMT-5</option>
<option>GMT-4</option>
<option>GMT-3</option>
<option>GMT-2</option>
<option>GMT-1</option>
<option>GMT</option>
<option>GMT1</option>
<option>GMT2</option>
<option>GMT3</option>
<option>GMT4</option>
<option>GMT5</option>
<option>GMT6</option>
<option>GMT7</option>
<option>GMT8</option>
<option>GMT9</option>
<option>GMT10</option>
<option>GMT11</option>
<option>GMT12</option>
<option>GMT13</option>
</select>
Articles:<input type=text size=6 name="artn" value="%artn%">
<input type=submit value="Set">
</form>
<hr>
<p><code>%%styleselect_end%% ========</code></p>
<p><code>%%error_begin%% ========</code></p>
<h2 align=center class="errormessage">Error!<br>エラー！</h2>
<p>
Sorry, writing failed! <code>m(_ _)m</code><br>
書き込みに失敗してしまいました．ごめんなさい．<code>m(_ _)m</code>
</p>
<p>
<strong><code>Error code: %error_code%</code></strong>
</p>
<p><code>%%error_end%% ========</code></p>
<p><code>%%error_lock_begin%% ========</code></p>
<p>
Cannot to lock data file.
Too heavy writing request?
</p>
<p>
Another reason, Under maintenance?
</p>
<p>
Sometime later, try to write again.
</p>
<p>
書き込み要求が集中してしまって，
データファイルをロックできなかったのが原因だと思われます．
</p>
<p>
もうひとつの可能性として，
管理者がメンテナンスのために
意図的にデータのあるディレクトリへの書き込みを禁止している
ということが考えられます．
</p>
<p>
どっちにしても，もう少し待って書き込んでみてください．
</p>
<p><code>%%error_lock_end%% ========</code></p>
<p><code>%%error_write_begin%% ========</code></p>
<p>
Too few disk spaces?
</p>
<p>
このWebサイトのディスク容量の不足が原因だと思われます．
</p>
<p><code>%%error_write_end%% ========</code></p>
<p><code>%%error_report_begin%% ========</code></p>
<p>
Please save writing text on your local host<br>
And report above <code>Error code</code>
to <a href="mailto:%email%">%email%</a>.
</p>
<p>
書き込もうとした内容は貴方のローカルホストに保存しといて，<br>
<a href="mailto:%email%">%email%</a>宛に
上記の<code>Error code</code>を報告してください．
</p>
<p><code>%%error_report_end%% ========</code></p>
<p><code>%%htmlck_begin%% ========</code></p>
<h2 align=center>Diagnostics<br>診断結果</h2>
<p>
Something problems in your writing text.<br>
Please check following points and correct.
</p>
<ul>
<li><a href="#inhibit">Inhibit HTML tags</a> exist?</li>
<li>End tag omitted?
<small>(Don't omit end tag, because easy HTML parser)</small></li>
</ul>
<p>
入力されたテキストに問題があります．<br>
以下の点に注意して，
もう一度かきこむ内容をチェックして修正してください．
</p>
<ul>
<li><a href="#inhibit">許可されていないHTMLタグ</a>を使っていないか？</li>
<li>終了タグを省略していないか？
<small>(手抜きの構文解析なんで終了タグは省略できません)</small></li>
</ul>
<h3><a name="inputtext">Input text<br>
入力されたテキスト</a></h3>
<p><code>%%diagnostics%%</code></p>
<p><code>%%htmlck_end%% ========</code></p>
<p><code>%%preview_begin%% ========</code></p>
<h2>Preview</h2>
<p><code>%%preview%%</code></p>
<p>
OK?
If NO errors, Submit once more to write.<br>
これでいいかな？
間違いがなければ，
もう一度送信ボタンを押してネ！
</p>
<p><code>%%preview_end%% ========</code></p>
<p><code>%%lastpage_begin%% ========</code></p>
<form method="POST" action="%myname%" %enctype% class="inputfield">
<input type=hidden name=pw value="%pw%">
<input type=hidden name=artn value="%artn%">
<input type=hidden name=previewname value="%previewname%">
<input type=hidden name=previewtype value="%previewtype%">
<input type=hidden name=previewtitle value="%previewtitle%">
<input type=hidden name=previewtext value="%previewtext%">
<input type=hidden name=fileinfo value="%fileinfo%">
<table border=0 summary="post form">
<tr>
<th class="inputfield">Name</th>
<td class="inputfield"><input id="inputname" type=text size=32 name=name value="%uname%"></td>
</tr>
<tr>
<th class="optionalinput">Mail</th>
<td class="optionalinput"><input id="inputmail" type=text size=40 name=uemail value="%uemail%"> (optional)</td>
</tr>
<tr>
<th class="optionalinput">Web</th>
<td class="optionalinput"><input id="inputweb" type=text size=48 name=uweb value="%uweb%"> (optional)</td>
</tr>
<tr>
<th class="optionalinput">Title</th>
<td class="optionalinput"><input id="inputtitle" type=text size=40 name=title value='%srctitle%'> (optional)</td>
</tr>
</table>
<div class="inputfield">
<strong>Text</strong> <small>(max %artsizemaxK%bytes)</small>
<input type=radio name=type value="Plain-text">Plain-text
<input type=radio name=type value="No-br">No-br
<input type=radio name=type value="Pre-formatted"><span class="preformatted">Pre-formatted</span>
<input type=radio name=type value="HTML">HTML
<input type=checkbox name=linkurl value=1>Link URL
</div>
<textarea rows=4 cols=72 name=str>%srcstr%</textarea><br>
<p><code>%%cgilib_begin%% ========</code></p>
<p><code>%%nopreview_begin%% ========</code></p>
<table border=0 summary="post file">
<tr>
<th class="optionalinput">File <small>(max %maxdataK%bytes)</small></th>
<td class="optionalinput"><input type=file name=file size=40> (optional)</td>
</tr>
</table>
<p><code>%%nopreview_end%% ========</code></p>
<p><code>%%cgilib_end%% ========</code></p>
<span class="optionalinput">Delete key:<input type=password name=ukey value="%ukey%">
(optional)</span>
<input type=submit value=" Write ">
<input type=reset value="Reset">
<a href="%myname%?doc=helpe.html">%str_help_en%</a>
<a href="%myname%?doc=help.html">%str_help%</a>
</form>
%body_post_message%
<p><code>%%lastpage_end%% ========</code></p>
<p><code>%%htmlck_begin%% ========</code></p>
<hr>
<h3><a name="inhibit">Inhibit HTML tags<br>
使えないHTMLタグ</a></h3>
<p>
You can write HTML tags
which is allowed to use in Division element (<div> ... </div>)
and Table cell element (<td> ... </td>)
defined
<a href="http://www.w3.org/TR/REC-html40/">HTML 4.0</a>.
But, <strong>Except followings</strong>
for Security and Web browser compatibility etc.
</p>
<p>
<a href="http://www.asahi-net.or.jp/~sd5a-ucd/rec-html40j/translation/cover.html">HTML 4.0</a>
で定義されてるタグのうち
DIV要素(<div> 〜 </div>)と
テーブルのセル要素(<td> 〜 </td>)
の中で使っていいものだけが使えます．
ただし，保安上の都合やWebブライザどうしの互換性の問題等のために，
<strong>次のタグは使用できない</strong>ようにしています．
</p>
<ul>
<li><!-- <var>comment</var> --></li>
<li><dir></li>
<li><menu></li>
<li><applet></li>
<li><basefont></li>
<li><script></li>
<li><map></li>
<li><iframe></li>
</ul>
<p>
For more details,
Go <a href="%myname%?debug=1">%myname%?debug=1</a>
and you can see the CGI script etc.
<br>
より詳しくは，
<a href="%myname%?debug=1">%myname%?debug=1</a>で
CGIスクリプトの内容をみてねネ．
</p>
<p><code>%%htmlck_end%% ========</code></p>
<p><code>%%debuginfo%%</code></p>
<hr>
<p><code>%%next_begin%% ========</code></p>
<form method="POST" action="%myname%">
<input type=hidden name=pw value="%pw%">
<input type=hidden name=artn value="%artn%">
<input type=hidden name=page value="%next%">
<input type=hidden name=grepmode value="%grepmode%">
<input type=hidden name=grepcase value="%grepcase%">
<input type=hidden name=re value='%re%'>
<p align=center>
<input type=submit value="Next (%nextn%)">
</p>
</form>
<p><code>%%next_end%% ========</code></p>
<form method="POST" action="%myname%">
<input type=hidden name=pw value="%pw%">
<input type=hidden name=artn value="%artn%">
<input type=hidden name=cmd value="delete">
%grep_message_en%
<p><code>%%articles%%</code></p>
<p><code>%%fmt_begin%% ========</code></p>
<p><code>%%_begin%%</code></p>
<p>
以下は，日付をどのような文字列に置換するかを定義するテーブルなの．
%month% %day% %ww% %hour% %am% %min% %sec% 等が置換されるんだよ．
どんな文字列に置換するかを
<code>','</code> (半角のカンマ)または改行で区切って列記してね．
このサンプルでは，例えば月の名前については次のように定義してます．
</p>
<pre>
Jan ..(中略).. Dec - 12個
January ..(中略).. December - 12個
睦月 ..(中略).. 師走 - 12個
</pre>
<p>
12 x 3 = 36個の名前を定義してることになってしまっちゃってるけど，
結局実際に%month%として使用される場合に，
最初の12個だけが参照されることになるから，
後の24個は，まったく無駄なメモリを消費してるだけなんだよね．
</p>
<p>
注意！<br>
<strong><code>' '</code> (半角のスペース)も無視されません．</strong>
(<code><pre></code>で桁をそろえるためにあえて有効にしています)
</p>
<table border=1 summary="Date format sample">
<caption>日付のサンプル</caption>
<tr>
<td><code>%date%</code></td>
<td><pre>1999/03/01 Mon 0:08:01 JST-9</pre></td>
</tr>
<tr>
<td><code>%yy%/%mm%/%dd% %ww% %HH%:%min%:%sec% %tz%</code></td>
<td><pre>1999/3/1 Mon 0:08:01 JST-9</pre></td>
</tr>
<tr>
<td><code>%ww% %month% %day% %hh%:%min%%am% %tz% %yy%</code></td>
<td><pre>Mon Mar 1 0:08am JST-9 1999</pre></td>
</tr>
</table>
<p><code>%%_end%%</code></p>
<p><code>%%month_begin%%</code></p>
Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec
January,February,March,April,May,June,July,August,September,October,November,December
睦月,如月,弥生,卯月,皐月,水無月,文月,葉月,長月,神無月,霜月,師走
<p><code>%%month_end%%</code></p>
<p><code>%%day_begin%%</code></p>
0, 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
零,壱,弐,参,四,伍,六,七,八,九,拾,
拾壱,拾弐,拾参,拾四,拾伍,拾六,拾七,拾八,拾九,
弐拾,弐拾壱,弐拾弐,弐拾参,弐拾四,弐拾伍,弐拾六,弐拾七,弐拾八,弐拾九,
参拾,参拾壱
<p><code>%%day_end%%</code></p>
<p><code>%%week_begin%%</code></p>
Sun,Mon,Tue,Wed,Thu,Fri,Sat
日,月,火,水,木,金,土
<p><code>%%week_end%%</code></p>
<p><code>%%hour_begin%%</code></p>
0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,
12,13,14,15,16,17,18,19,20,21,22,23
零,壱,弐,参,四,伍,六,七,八,九,拾,拾壱,
拾弐,拾参,拾四,拾伍,拾六,拾七,拾八,拾九,弐拾,弐拾壱,弐拾弐,弐拾参
<p><code>%%hour_end%%</code></p>
<p><code>%%min_begin%%</code></p>
00,01,02,03,04,05,06,07,08,09,
10,11,12,13,14,15,16,17,18,19,
20,21,22,23,24,25,26,27,28,29,
30,31,32,33,34,35,36,37,38,39,
40,41,42,43,44,45,46,47,48,49,
50,51,52,53,54,55,56,57,58,59
<p><code>%%min_end%%</code></p>
<p><code>%%sec_begin%%</code></p>
00,01,02,03,04,05,06,07,08,09,
10,11,12,13,14,15,16,17,18,19,
20,21,22,23,24,25,26,27,28,29,
30,31,32,33,34,35,36,37,38,39,
40,41,42,43,44,45,46,47,48,49,
50,51,52,53,54,55,56,57,58,59
<p><code>%%sec_end%%</code></p>
<p><code>%%ampm_begin%%</code></p>
am,pm
午前,午後
<p><code>%%ampm_end%%</code></p>
<p><code>%%head_begin%%</code></p>
<p><code>%%head_end%%</code></p>
<p><code>%%body_begin%%</code></p>
<table class="artable" border=1 width="100%" summary="article">
<tr class="headline">
<td width="62%">
<input type=checkbox name=target value="%time%.%pid%">
<span class="serial">%sr%</span>
<span class="name">%wname%</span>
<span class="subject">%title%</span>
</td>
<td class="date">
<code>%yy%/%mm%/%dd% %ww% %HH%:%min%:%sec% %tz%</code>
</td>
</tr>
<tr><td class="article" colspan=2>
<code>%%html_begin%%</code><br>
%str%
<p>%imgfile%</p>
<div class="remoteinfo">%host% %agent%</div>
<code>%%html_end%%</code><br>
<code>%%pre_begin%%</code><br>
<pre>%str%</pre>
<p>%imgfile%</p>
<div class="remoteinfo">%host% %agent%</div>
<code>%%pre_end%%</code>
</td></tr>
</table>
<p><code>%%body_end%%</code></p>
<p><code>%%tail_begin%%</code></p>
<p><code>%%tail_end%%</code></p>
<p><code>%%fmt_end%% ========</code></p>
<p class="optionalinput">
Delete key:<input type=password name=opkey value="">
<input type=submit value="Delete">
</p>
</form>
<p><code>%%previous_begin%% ========</code></p>
<form method="POST" action="%myname%">
<input type=hidden name=pw value="%pw%">
<input type=hidden name=artn value="%artn%">
<input type=hidden name=page value="%previous%">
<input type=hidden name=lastscan value="%lastscan%">
<input type=hidden name=grepmode value="%grepmode%">
<input type=hidden name=grepcase value="%grepcase%">
<input type=hidden name=re value='%re%'>
<input type=submit value="Previous (%prevn%)">
</form>
<p><code>%%previous_end%% ========</code></p>
<form method="POST" action="%myname%">
<input type=hidden name=pw value="%pw%">
<input type=hidden name=artn value="%artn%">
<input type=hidden name=page value="%page%">
<input type=hidden name=cmd value="grep">
String:<input type=text size=32 name=re value='%re%'>
<input type=radio name=grepmode value="and">and
<input type=radio name=grepmode value="or">or
<input type=radio name=grepmode value="re">RE
<input type=checkbox name=grepcase value="sensitive">Case-sensitive
<input type=submit value="Find">
</form>
%body_bottom_message%
<hr>
<a href="%tope%">%str_back_en%</a><br>
<a href="%top%">%str_back%</a>
<p align=right>
<a href="http://www.oersted.co.jp/~yav/wb/"><img
src="http://www.oersted.co.jp/~yav/image/wb.gif" width=120 height=32
border=0 alt="%myname%"></a> version %version%
by <a href="mailto:%yavemail%">%yav%</a>
</p>
</body>
</html>
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN"> <html> <head> <meta http-equiv="Content-Type" content="text/html; charset=Shift_JIS"> <!-- 美乳 --> <title>Whiteboard password</title> <meta name="description" content="Whiteboard passwd"> <meta name="Author" content="%author%"> <link rev="MADE" href="mailto:%email%"> <link rel="PREV" href="%top%"> </head> <body bgcolor="#ffffcc" background="bg.gif" text=black link=blue vlink=purple alink=red> <h1 align=center>Secure whiteboard password</h1> <form method="POST" action="%myname%"> <!-- Name: <input type=text name=name value="%uname%"><br> 本当はこのように名前も入力したいとこだが， そうすると[Enter]でフォームを提出しなくなるので やめることにする． --> Password: <input type=password name=pw value="%pw%"> <input type=submit> <input type=reset> </form> <p> <strong>ただいまMember onlyモードの実験中</strong><br> パスワードは，<font color=green><strong><code>%userpasswd%</code></strong></font>です． </p> <p> ここで入力したパスワードはクッキーを使って保存されるので， クッキーの賞味期限内(初期設定31日間)は パスワードの入力なしで入れます． Webブラウザがクッキーを受け取らない設定の場合は， 毎回入力してください． </p> <hr> <a href="%tope%">Return home page</a><br> <a href="%top%">ホームページに戻る</a> </body> </html>
package htmlck;
########
# HTML tag check for posting BBS article
# written by yav <yav@bigfoot.com>
#
# 概要:
# BBSに投稿する記事がHTMLの文書定義に従っているかを確認するスクリプトです．
# ただし，プログラム簡略化のため，
# 単に使用可能なタグかどうかをチェックしてるだけです．
# 使用可能かどうかの判断はW3Cの文書型定義を参考にしています．
# 属性値はクォートの確認だけで，あとはほとんどノーチェックです．
# また，本来は省略可とされてるタグも省略できません．
# Sample document 1: これはダメです！
# <dl>
# <dt>DTD<dd>Document Type Definition
# <dt>HTML<dd>Hyper Text Mark-up Language
# </dl>
# Sample document 2: こう書いてください
# <dl>
# <dt>DTD</dt><dd>Document Type Definition</dd>
# <dt>HTML</dt><dd>Hyper Text Mark-up Language</dd>
# </dl>
#
#
# 使い方:
# チェックしたいテキストが$textに入ってるとしたら，
# @errors = &htmlck'report($text, 'p');
# というように最初の引数にソレを指定してreportをコールします．
# 2番目の引数はそのテキストがどんなタグ（正確には要素）の中に
# 入ってるものとしてチェックするかです．
# 通常，BBSの記事は<p>か<div>もしくは<td>の中に入って表示されると思いますが，
# たとえば，<p>で囲んで表示する場合には
# @errors = &htmlck'report($text, 'p');
# とやって，<p>の中に入ってるものとしてチェックします．
#
# もし構文的に問題があれば，
# 与えられたテキストを誤った部分と正しい部分に分解したリストを返します．
# たとえば，"<bad>Bad</bad>"をチェックすると，
# ("1<bad>", "0Bad", "1</bad>") というリストが返されると思います．
# もしエラーが何もなければ，空のリストが返されます．
#
# 通常は HTML-3.2 としてチェックしますが，
# &htmlck'html_version('4.01 Transitional');
# のように html_versionをコールすると
# HTML-4.01としてチェックするようになります．
# いまのとこ，'3.2'と'4.01'しか対応してません．
#
# 具体的な使い方は↓のサンプルプログラムを見てください．
#
# Sample program:
# require "jcode.pl";
# require "htmlck.pl";
# @data = <>;
# $_ = join("", @data);
# &jcode'convert(*_, 'euc'); # '
# &htmlck'html_version('4.01 Transitional'); # ' '4.01' or '3.2'(default)
# @list = &htmlck'report($_, 'body'); # '
# foreach (@list) {
# ($f, $_) = split(//, $_, 2);
# s/&/&/g;
# s/</</g;
# s/>/>/g;
# $_ = "<font color=red>$_</font>" if $f;
# }
# $_ = join("", @list);
# &jcode'convert(*_, 'sjis'); # '
# print;
# exit 0;
#
$rcsid = q$Id: htmlck.pl,v 1.1 2005/10/23 06:26:27 yav Exp $;
$version = ($rcsid =~ /\S+\s+\S+\s+([\d.])/) ? $1 : 'unknown';
&init if !$html_version;
sub init
{
$attr_check = 1 if !defined($attr_check);
&html_version("3.2");
}
sub html_version
{
$html_version = $_[0];
}
sub setup_html_table
{
if ($setup_version != $html_version) {
undef %e;
if ($html_version >= 4) {
&init_4_01;
} else {
&init_3_2;
}
$setup_version = $html_version;
}
}
###
# Setup HTML tag list (Ref. DTD HTML 3.2 Final)
sub init_3_2
{
### !ENTITY ###
@empty = ("empty");
@pcdata = @cdata = ();
@heading = ("h1","h2","h3","h4","h5","h6");
@list = ("ul","ol"); # "dir", "menu"
@preformatted = ("pre"); # "xmp", "listing"
@font = ("tt","i","b","u","strike","big","small","sub","sup");
@phrase = ("em","strong","code","samp","kbd","var","cite");
@special = ("a","img","font","br"); # "applet","basefont","script","map"
@form = ("input","select","textarea");
@text = (@font,@phrase,@special,@form);
@block = ("p",@list,@preformatted,"dl","div","center","blockquote",
"form","hr","table"); # "isindex"
@flow = (@text,@block);
@body_content = (@heading,@text,@block,"address");
@address_content = (@text, "p");
@head_content = ("title", "isindex", "base");
@head_misc = ("script", "style", "meta", "link");
### !ELEMENT ###
foreach (@font, @phrase) { &element($_, 1, 1, @text); }
&element("font", 1, 1, @text);
&element("br", 1, 0, @empty);
&element("body", 0, 0, @body_content);
&element("address", 1, 1, @address_content);
&element("div", 1, 1, @body_content);
&element("center", 1, 1, @body_content);
&element("a", 1, 1, &exclude("a", @text));
&element("img", 1, 0, @empty);
&element("hr", 1, 0, @empty);
&element("p", 1, 0, @text);
foreach (@heading) { &element($_, 1, 1, @text); }
&element("pre", 1, 1, &exclude("pre", @text));
&element("blockquote", 1, 1, @body_content);
&element("dl", 1, 1, "dt", "dd");
&element("dt", 1, 0, @text);
&element("dd", 1, 0, @flow);
&element("ol", 1, 1, "li");
&element("ul", 1, 1, "li");
&element("li", 1, 0, @flow);
&element("form", 1, 1, &exclude("form", @body_content));
&element("input", 1, 0, @empty);
&element("select", 1, 1, "option");
&element("option", 1, 0, @pcdata);
&element("textarea", 1, 1, @pcdata);
&element("table", 1, 1, "caption", "tr");
&element("tr", 1, 0, "th", "td");
&element("th", 1, 0, @body_content);
&element("td", 1, 0, @body_content);
&element("caption", 1, 1, @text);
&element("head", 0, 0, @head_content, @head_misc);
&element("title", 1, 1, @pcdata);
&element("isindex", 1, 0, @empty);
&element("base", 1, 0, @empty);
&element("meta", 1, 0, @empty);
&element("style", 1, 1, @cdata);
&element("script", 1, 1, @cdata);
&element("link", 1, 0, @empty);
&element("html", 0, 0, "head", "body");
&element("!doctype", 0, 0, @empty);
&element("sgml", 0, 0, "!doctype", "html");
}
###
# Setup HTML tag list (Ref. DTD HTML 4.01 Transitional)
sub init_4_01
{
### !ENTITY ###
@empty = ("empty");
@pcdata = @cdata = ();
@stylesheet = @cdata;
@head_misc = ("style", "meta", "link", "object"); # "script"
@heading = ("h1", "h2", "h3", "h4", "h5", "h6");
@list = ("ul", "ol"); # "dir", "menu"
@preformatted = ("pre");
@fontstyle = ("tt", "i", "b", "u", "s", "strike", "big", "small");
@phrase = ("em", "strong", "dfn", "code", "samp", "kbd", "var", "cite",
"abbr", "acronym");
@special = ("a", "img", # "applet",
"object", "font", # "basefont",
"br", # "script", "map",
"q", "sub", "sup", "span", "bdo"); # "iframe"
@formctrl = ("input", "select", "textarea", "label", "button");
@inline = (@pcdata, @fontstyle, @phrase, @special, @formctrl);
@block = ("p", @heading, @list, @preformatted, "dl", "div", "center",
"noscript", "noframes", "blockquote", "form", "isindex", "hr",
"table", "fieldset", "address");
@flow = (@block, @inline);
@head_content = ("title", "isindex", "base");
@html_content = ("head", "body");
### !ELEMENT ###
foreach (@fontstyle, @phrase) { &element($_, 1, 1, @inline); }
&element("sub", 1, 1, @inline);
&element("sup", 1, 1, @inline);
&element("span", 1, 1, @inline);
&element("bdo", 1, 1, @inline);
# &element("basefont", 1, 0, @empty);
&element("font", 1, 1, @inline);
&element("br", 1, 0, @empty);
&element("body", 0, 0, @flow, "ins", "del");
&element("address", 1, 1, @inline, "p");
&element("div", 1, 1, @flow);
&element("center", 1, 1, @flow);
&element("a", 1, 1, grep(!/^a$/, @inline));
# &element("map", 1, 1, @block, "area");
# &element("area", 1, 0, @empty);
&element("link", 1, 0, @empty);
&element("img", 1, 0, @empty);
&element("object", 1, 1, "param", @flow);
&element("param", 1, 0, @empty);
# &element("applet", 1, 1, @param, @flow);
&element("hr", 1, 0, @empty);
&element("p", 1, 0, @inline);
foreach (@heading) {&element($_, 1, 1, @inline);}
&element("pre", 1, 1, grep(!/^(img|object|applet|big|small|sub|sup|font|basefont)$/, @inline));
&element("q", 1, 1, @inline);
&element("blockquote", 1, 1, @flow);
&element("ins", 1, 1, @flow);
&element("del", 1, 1, @flow);
&element("dl", 1, 1, "dt", "dd");
&element("dt", 1, 0, @inline);
&element("dd", 1, 0, @flow);
&element("ol", 1, 1, "li");
&element("ul", 1, 1, "li");
# &element("dir", 1, 1, "li"); # -(%block;)
# &element("menu", 1, 1, "li"); # -(%block;)
&element("li", 1, 0, @flow);
&element("form", 1, 1, grep(!/^form$/, @flow));
&element("label", 1, 1, grep(!/^label$/, @inline));
&element("input", 1, 0, @empty);
&element("select", 1, 1, "optgroup", "option");
&element("optgroup", 1, 1, "option");
&element("option", 1, 0, @pcdata);
&element("textarea", 1, 1, @pcdata);
&element("fieldset", 1, 1, @pcdata, "legend", @flow);
&element("legend", 1, 1, @inline);
&element("button", 1, 1, grep(!/^(a|input|select|textarea|label|button|form|isindex|fieldset|iframe)$/, @flow)); # -(A|%formctrl;|FORM|ISINDEX|FIELDSET|IFRAME)
&element("table", 1, 1, "caption", "col", "colgroup", "thead", "tfoot", "tbody", "tr"); # "tr" for Omit "tbody" begin tag
&element("caption", 1, 1, @inline);
&element("thead", 1, 0, "tr");
&element("tfoot", 1, 0, "tr");
&element("tbody", 0, 0, "tr");
&element("colgroup", 1, 0, "col");
&element("col", 1, 0, @empty);
&element("tr", 1, 0, "th", "td");
&element("th", 1, 0, @flow);
&element("td", 1, 0, @flow);
&element("head", 0, 0, @head_content, @head_misc);
&element("title", 1, 1, @pcdata); # -(%head.misc;)
&element("isindex", 1, 0, @empty);
&element("base", 1, 0, @empty);
&element("meta", 1, 0, @empty);
&element("style", 1, 1, @stylesheet);
# &element("script", 1, 1, @cdata); # %Script
&element("noscript", 1, 1, @flow);
&element("html", 0, 0, @html_content);
&element("!doctype", 0, 0, @empty);
&element("sgml", 0, 0, "!doctype", "html");
}
sub exclude
{
local($p, @a) = @_;
grep(!/^$p$/, @a);
}
sub element
{
local($name, $begin, $end, @contents) = @_;
$e{$name} = join(',', $begin, $end, @contents);
}
sub c_element
{
local($_) = @_;
local($begin, $end, @contents);
($begin, $end, @contents) = split(',', $e{$_});
@contents;
}
sub is_empty
{
local($_) = @_;
y/A-Z/a-z/;
(&c_element($_))[0] eq $empty[0];
}
########
# check and report errors
# argument string for check
# return error list (return () if no errors)
# example:
# "<em>Good!</em> <bad>Bad!</bad>"
# ^^^^^ ^^^^^^
# "0<em>Good!</em> ", "1<bad>", "0Bad!", "1</bad>"
#
sub report
{
local($str, $context) = @_;
local($p, $i, $from, $to, @out, @error);
@error = &check($str, $context);
if (@error) {
$p = 0;
for ($i = 0; $i < @error; $i++) {
($from, $to) = split(/-/, $error[$i]);
push(@out, "0" . substr($str, $p, $from-$p));
push(@out, "1" . substr($str, $from, $to-$from));
$p = $to;
}
push(@out, "0" . substr($str, $p));
}
@out;
}
###
# check HTML tags
# return error position list (from0-to0, from1-to1, ... fromN-toN)
#
sub check
{
local($str, $context) = @_;
local($f, $from, $to, @error, @lvl, @lvlerr);
&setup_html_table;
$context = $context || "div";
@lvl = ($context);
$from = 0;
while (($from = &index_ltgt($str, $from)) >= 0) {
last unless @lvl;
$f = 1;
if (substr($str, $from, 1) eq "<") {
$to = &index_ltgt($str, $from+1);
if ($to < 0 || substr($str, $to, 1) ne ">") {
$to = $from+1; # single '<' Not found pair '>'
} else {
$to++; # skip '>'
$_ = substr($str, $from, $to-$from);
$f = $attr_check ? &attr_check($_) : 0;
if (!$f) {
$f = 1;
s#^<\s*(!?/?\w*)[\000-\377]*#$1#;
if (s#^/##) {
if (!&is_empty($_) && $lvl[$#lvl] eq $_) {
pop(@lvl);
pop(@lvlerr);
$f = 0 if @lvl;
}
} else {
if (&match($_, &c_element($lvl[$#lvl]))) {
if (!&is_empty($_)) {
push(@lvl, $_);
push(@lvlerr, "$from-$to");
}
$f = 0;
}
}
}
}
} else {
$to = $from+1; # single '>' Not found pair '<'
}
push(@error, "$from-$to") if $f;
$from = $to;
}
push(@error, @lvlerr);
sort numerically @error;
}
sub numerically { $a <=> $b; }
sub attr_check
{
local($_) = @_;
(y/"// & 1) || (y/'// & 1);
}
sub index_ltgt
{
local($str, $pos) = @_;
local($lt, $gt, $r);
$lt = index($str, '<', $pos);
$gt = index($str, '>', $pos);
if ($lt < 0) {
$r = $gt;
} elsif ($gt < 0) {
$r = $lt;
} elsif ($lt < $gt) {
$r = $lt;
} else {
$r = $gt;
}
$r;
}
sub match
{
local($_, @list) = (@_);
local($r, $tag);
$r = 0;
foreach $tag (@list) {
if (/^$tag$/i) {
$r = 1;
last;
}
}
$r;
}
1;
# Local Variables:
# mode:perl
# End:
package jcode;
;######################################################################
;#
;# jcode.pl: Perl library for Japanese character code conversion
;#
;# Copyright (c) 1995-1999 Kazumasa Utashiro <utashiro@iij.ad.jp>
;# Internet Initiative Japan Inc.
;# 3-13 Kanda Nishiki-cho, Chiyoda-ku, Tokyo 101-0054, Japan
;#
;# Copyright (c) 1992,1993,1994 Kazumasa Utashiro
;# Software Research Associates, Inc.
;#
;# Original version was developed under the name of srekcah@sra.co.jp
;# February 1992 and it was called kconv.pl at the beginning. This
;# address was a pen name for group of individuals and it is no longer
;# valid.
;#
;# Use and redistribution for ANY PURPOSE, without significant
;# modification, is granted as long as all copyright notices are
;# retained. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND
;# ANY EXPRESS OR IMPLIED WARRANTIES ARE DISCLAIMED.
;#
;# The latest version is available here:
;#
;# ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
;#
;; $rcsid = q$Id: jcode.pl,v 2.10 1999/01/10 13:43:14 utashiro Exp $;
;#
;######################################################################
;#
;# PERL4 INTERFACE:
;#
;# &jcode'getcode(*line)
;# Return 'jis', 'sjis', 'euc' or undef according to
;# Japanese character code in $line. Return 'binary' if
;# the data has non-character code.
;#
;# When evaluated in array context, it returns a list
;# contains two items. First value is the number of
;# characters which matched to the expected code, and
;# second value is the code name. It is useful if and
;# only if the number is not 0 and the code is undef;
;# that case means it couldn't tell 'euc' or 'sjis'
;# because the evaluation score was exactly same. This
;# interface is too tricky, though.
;#
;# Code detection between euc and sjis is very difficult
;# or sometimes impossible or even lead to wrong result
;# when it includes JIS X0201 KANA characters. So JIS
;# X0201 KANA is ignored for automatic code detection.
;#
;# &jcode'convert(*line, $ocode [, $icode [, $option]])
;# Convert the contents of $line to the specified
;# Japanese code given in the second argument $ocode.
;# $ocode can be any of "jis", "sjis" or "euc", or use
;# "noconv" when you don't want the code conversion.
;# Input code is recognized automatically from the line
;# itself when $icode is not supplied (JIS X0201 KANA is
;# ignored in code detection. See the above descripton
;# of &getcode). $icode also can be specified, but
;# xxx2yyy routine is more efficient when both codes are
;# known.
;#
;# It returns the code of input string in scalar context,
;# and a list of pointer of convert subroutine and the
;# input code in array context.
;#
;# Japanese character code JIS X0201, X0208, X0212 and
;# ASCII code are supported. X0212 characters can not be
;# represented in SJIS and they will be replased by
;# "geta" character when converted to SJIS.
;#
;# See next paragraph for $option parameter.
;#
;# &jcode'xxx2yyy(*line [, $option])
;# Convert the Japanese code from xxx to yyy. String xxx
;# and yyy are any convination from "jis", "euc" or
;# "sjis". They return *approximate* number of converted
;# bytes. So return value 0 means the line was not
;# converted at all.
;#
;# Optional parameter $option is used to specify optional
;# conversion method. String "z" is for JIS X0201 KANA
;# to X0208 KANA, and "h" is for reverse.
;#
;# $jcode'convf{'xxx', 'yyy'}
;# The value of this associative array is pointer to the
;# subroutine jcode'xxx2yyy().
;#
;# &jcode'to($ocode, $line [, $icode [, $option]])
;# &jcode'jis($line [, $icode [, $option]])
;# &jcode'euc($line [, $icode [, $option]])
;# &jcode'sjis($line [, $icode [, $option]])
;# These functions are prepared for easy use of
;# call/return-by-value interface. You can use these
;# funcitons in s///e operation or any other place for
;# convenience.
;#
;# &jcode'jis_inout($in, $out)
;# Set or inquire JIS start and end sequences. Default
;# is "ESC-$-B" and "ESC-(-B". If you supplied only one
;# character, "ESC-$" or "ESC-(" is prepended for each
;# character respectively. Acutually "ESC-(-B" is not a
;# sequence to end JIS code but a sequence to start ASCII
;# code set. So `in' and `out' are somewhat misleading.
;#
;# &jcode'get_inout($string)
;# Get JIS start and end sequences from $string.
;#
;# &jcode'cache()
;# &jcode'nocache()
;# &jcode'flush()
;# Usually, converted character is cached in memory to
;# avoid same calculations have to be done many times.
;# To disable this caching, call &jcode'nocache(). It
;# can be revived by &jcode'cache() and cache is flushed
;# by calling &jcode'flush(). &cache() and &nocache()
;# functions return previous caching state.
;#
;# ---------------------------------------------------------------
;#
;# &jcode'h2z_xxx(*line)
;# JIS X0201 KANA (so-called Hankaku-KANA) to X0208 KANA
;# (Zenkaku-KANA) code conversion routine. String xxx is
;# any of "jis", "sjis" and "euc". From the difficulty
;# of recognizing code set from 1-byte KATAKANA string,
;# automatic code recognition is not supported.
;#
;# &jcode'z2h_xxx(*line)
;# X0208 to X0201 KANA code conversion routine. String
;# xxx is any of "jis", "sjis" and "euc".
;#
;# $jcode'z2hf{'xxx'}
;# $jcode'h2zf{'xxx'}
;# These are pointer to the corresponding function just
;# as $jcode'convf.
;#
;# ---------------------------------------------------------------
;#
;# &jcode'tr(*line, $from, $to [, $option])
;# &jcode'tr emulates tr operator for 2 byte code. Only 'd'
;# is interpreted as an option.
;#
;# Range operator like `A-Z' for 2 byte code is partially
;# supported. Code must be JIS or EUC, and first byte
;# have to be same on first and last character.
;#
;# CAUTION: Handling range operator is a kind of trick
;# and it is not perfect. So if you need to transfer `-'
;# character, please be sure to put it at the beginning
;# or the end of $from and $to strings.
;#
;# &jcode'trans($line, $from, $to [, $option)
;# Same as &jcode'tr but accept string and return string
;# after translation.
;#
;# ---------------------------------------------------------------
;#
;# &jcode'init()
;# Initialize the variables used in this package. You
;# don't have to call this when using jocde.pl by `do' or
;# `require' interface. Call it first if you embedded
;# the jcode.pl at the end of your script.
;#
;######################################################################
;#
;# PERL5 INTERFACE:
;#
;# Current jcode.pl is written in Perl 4 but it is possible to
;# use from Perl 5 using `references'. Fully perl5 capable version
;# is future issue.
;#
;# jcode::getcode(\$line)
;# jcode::convert(\$line, $ocode [, $icode [, $option]])
;# jcode::xxx2yyy(\$line [, $option])
;# &{$jcode::convf{'xxx', 'yyy'}}(\$line)
;# jcode::to($ocode, $line [, $icode [, $option]])
;# jcode::jis($line [, $icode [, $option]])
;# jcode::euc($line [, $icode [, $option]])
;# jcode::sjis($line [, $icode [, $option]])
;# jcode::jis_inout($in, $out)
;# jcode::get_inout($string)
;# jcode::cache()
;# jcode::nocache()
;# jcode::flush()
;# jcode::h2z_xxx(\$line)
;# jcode::z2h_xxx(\$line)
;# &{$jcode::z2hf{'xxx'}}(\$line)
;# &{$jcode::h2zf{'xxx'}}(\$line)
;# jcode::tr(\$line, $from, $to [, $option])
;# jcode::trans($line, $from, $to [, $option)
;# jcode::init()
;#
;######################################################################
;#
;# SAMPLES
;#
;# Convert any Kanji code to JIS and print each line with code name.
;#
;# while (<>) {
;# $code = &jcode'convert(*_, 'jis');
;# print $code, "\t", $_;
;# }
;#
;# Convert all lines to JIS according to the first recognized line.
;#
;# while (<>) {
;# print, next unless /[\033\200-\377]/;
;# (*f, $icode) = &jcode'convert(*_, 'jis');
;# print;
;# defined(&f) || next;
;# while (<>) { &f(*_); print; }
;# last;
;# }
;#
;# The safest way of JIS conversion.
;#
;# while (<>) {
;# ($matched, $code) = &jcode'getcode(*_);
;# print, next unless (@buf || $matched);
;# push(@buf, $_);
;# next unless $code;
;# eval "&jcode'${code}2jis(*_), print while (\$_ = shift(\@buf));";
;# eval "&jcode'${code}2jis(*_), print while (\$_ = <>);";
;# last;
;# }
;#
;######################################################################
;#
;# Call initialize function if it is not called yet. This may sound
;# strange but it makes easy to embed the jcode.pl at the end of
;# script. Call &jcode'init at the beginning of the script in that
;# case.
;#
&init unless defined $version;
;#
;# Initialize variables.
;#
sub init {
$version = $rcsid =~ /,v ([\d.]+)/ ? $1 : 'unkown';
$re_bin = '[\000-\006\177\377]';
$re_jis0208_1978 = '\e\$\@';
$re_jis0208_1983 = '\e\$B';
$re_jis0208_1990 = '\e&\@\e\$B';
$re_jis0208 = "$re_jis0208_1978|$re_jis0208_1983|$re_jis0208_1990";
$re_jis0212 = '\e\$\(D';
$re_jp = "$re_jis0208|$re_jis0212";
$re_asc = '\e\([BJ]';
$re_kana = '\e\(I';
$esc_0208 = "\e\$B";
$esc_0212 = "\e\$(D";
$esc_asc = "\e(B";
$esc_kana = "\e(I";
$re_sjis_c = '[\201-\237\340-\374][\100-\176\200-\374]';
$re_sjis_kana = '[\241-\337]';
$re_euc_c = '[\241-\376][\241-\376]';
$re_euc_kana = '\216[\241-\337]';
$re_euc_0212 = '\217[\241-\376][\241-\376]';
# Use `geta' for undefined character code
$undef_sjis = "\x81\xac";
$cache = 1;
# X0201 -> X0208 KANA conversion table. Looks weird? Not that
# much. This is simply JIS text without escape sequences.
($h2z_high = $h2z = <<'__TABLE_END__') =~ tr/\041-\176/\241-\376/;
! !# $ !" % !& " !V # !W
^ !+ _ !, 0 !<
' %! ( %# ) %% * %' + %)
, %c - %e . %g / %C
1 %" 2 %$ 3 %& 4 %( 5 %*
6 %+ 7 %- 8 %/ 9 %1 : %3
6^ %, 7^ %. 8^ %0 9^ %2 :^ %4
; %5 < %7 = %9 > %; ? %=
;^ %6 <^ %8 =^ %: >^ %< ?^ %>
@ %? A %A B %D C %F D %H
@^ %@ A^ %B B^ %E C^ %G D^ %I
E %J F %K G %L H %M I %N
J %O K %R L %U M %X N %[
J^ %P K^ %S L^ %V M^ %Y N^ %\
J_ %Q K_ %T L_ %W M_ %Z N_ %]
O %^ P %_ Q %` R %a S %b
T %d U %f V %h
W %i X %j Y %k Z %l [ %m
\ %o ] %s & %r 3^ %t
__TABLE_END__
%h2z = split(/\s+/, $h2z . $h2z_high);
%z2h = reverse %h2z;
$convf{'jis' , 'jis' } = *jis2jis;
$convf{'jis' , 'sjis'} = *jis2sjis;
$convf{'jis' , 'euc' } = *jis2euc;
$convf{'euc' , 'jis' } = *euc2jis;
$convf{'euc' , 'sjis'} = *euc2sjis;
$convf{'euc' , 'euc' } = *euc2euc;
$convf{'sjis' , 'jis' } = *sjis2jis;
$convf{'sjis' , 'sjis'} = *sjis2sjis;
$convf{'sjis' , 'euc' } = *sjis2euc;
$h2zf{'jis' } = *h2z_jis;
$z2hf{'jis' } = *z2h_jis;
$h2zf{'euc' } = *h2z_euc;
$z2hf{'euc' } = *z2h_euc;
$h2zf{'sjis'} = *h2z_sjis;
$z2hf{'sjis'} = *z2h_sjis;
}
;#
;# Set escape sequences which should be put before and after Japanese
;# (JIS X0208) string.
;#
sub jis_inout {
$esc_0208 = shift || $esc_0208;
$esc_0208 = "\e\$$esc_0208" if length($esc_0208) == 1;
$esc_asc = shift || $esc_asc;
$esc_asc = "\e\($esc_asc" if length($esc_asc) == 1;
($esc_0208, $esc_asc);
}
;#
;# Get JIS in and out sequences from the string.
;#
sub get_inout {
local($esc_0208, $esc_asc);
$_[$[] =~ /($re_jis0208)/o && ($esc_0208 = $1);
$_[$[] =~ /($re_asc)/o && ($esc_asc = $1);
($esc_0208, $esc_asc);
}
;#
;# Recognize character code.
;#
sub getcode {
local(*_) = @_;
local($matched, $code);
if (!/[\e\200-\377]/) { # not Japanese
$matched = 0;
$code = undef;
} # 'jis'
elsif (/$re_jp|$re_asc|$re_kana/o) {
$matched = 1;
$code = 'jis';
}
elsif (/$re_bin/o) { # 'binary'
$matched = 0;
$code = 'binary';
}
else { # should be 'euc' or 'sjis'
local($sjis, $euc);
$sjis += length($1) while /(($re_sjis_c)+)/go;
$euc += length($1) while /(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/go;
$matched = &max($sjis, $euc);
$code = ('euc', undef, 'sjis')[($sjis<=>$euc) + $[ + 1];
}
wantarray ? ($matched, $code) : $code;
}
sub max { $_[ $[ + ($_[$[] < $_[$[+1]) ]; }
;#
;# Convert any code to specified code.
;#
sub convert {
local(*_, $ocode, $icode, $opt) = @_;
return (undef, undef) unless $icode = $icode || &getcode(*_);
return (undef, $icode) if $icode eq 'binary';
$ocode = 'jis' unless $ocode;
$ocode = $icode if $ocode eq 'noconv';
local(*f) = $convf{$icode, $ocode};
&f(*_, $opt);
wantarray ? (*f, $icode) : $icode;
}
;#
;# Easy return-by-value interfaces.
;#
sub jis { &to('jis', @_); }
sub euc { &to('euc', @_); }
sub sjis { &to('sjis', @_); }
sub to {
local($ocode, $_, $icode, $opt) = @_;
&convert(*_, $ocode, $icode, $opt);
$_;
}
sub what {
local($_) = @_;
&getcode(*_);
}
sub trans {
local($_) = shift;
&tr(*_, @_);
$_;
}
;#
;# SJIS to JIS
;#
sub sjis2jis {
local(*_, $opt, $n) = @_;
&sjis2sjis(*_, $opt) if $opt;
s/(($re_sjis_c|$re_sjis_kana)+)/&_sjis2jis($1) . $esc_asc/geo;
$n;
}
sub _sjis2jis {
local($_) = shift;
s/(($re_sjis_c)+|($re_sjis_kana)+)/&__sjis2jis($1)/geo;
$_;
}
sub __sjis2jis {
local($_) = shift;
if (/^$re_sjis_kana/o) {
$n += tr/\241-\337/\041-\137/;
$esc_kana . $_;
} else {
$n += s/($re_sjis_c)/$s2e{$1}||&s2e($1)/geo;
tr/\241-\376/\041-\176/;
$esc_0208 . $_;
}
}
;#
;# EUC to JIS
;#
sub euc2jis {
local(*_, $opt, $n) = @_;
&euc2euc(*_, $opt) if $opt;
s/(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/&_euc2jis($1) . $esc_asc/geo;
$n;
}
sub _euc2jis {
local($_) = shift;
s/(($re_euc_c)+|($re_euc_kana)+|($re_euc_0212)+)/&__euc2jis($1)/geo;
$_;
}
sub __euc2jis {
local($_) = shift;
local($esc) = tr/\216//d ? $esc_kana : tr/\217//d ? $esc_0212 : $esc_0208;
$n += tr/\241-\376/\041-\176/;
$esc . $_;
}
;#
;# JIS to EUC
;#
sub jis2euc {
local(*_, $opt, $n) = @_;
s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2euc($1,$2)/geo;
&euc2euc(*_, $opt) if $opt;
$n;
}
sub _jis2euc {
local($esc, $_) = @_;
if ($esc !~ /$re_asc/o) {
$n += tr/\041-\176/\241-\376/;
if ($esc =~ /$re_kana/o) {
s/([\241-\337])/\216$1/g;
}
elsif ($esc =~ /$re_jis0212/o) {
s/([\241-\376][\241-\376])/\217$1/g;
}
}
$_;
}
;#
;# JIS to SJIS
;#
sub jis2sjis {
local(*_, $opt, $n) = @_;
&jis2jis(*_, $opt) if $opt;
s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2sjis($1,$2)/geo;
$n;
}
sub _jis2sjis {
local($esc, $_) = @_;
if ($esc =~ /$re_jis0212/o) {
s/../$undef_sjis/g;
$n = length;
}
elsif ($esc !~ /$re_asc/o) {
$n += tr/\041-\176/\241-\376/;
s/($re_euc_c)/$e2s{$1}||&e2s($1)/geo if $esc =~ /$re_jp/o;
}
$_;
}
;#
;# SJIS to EUC
;#
sub sjis2euc {
local(*_, $opt,$n) = @_;
$n = s/($re_sjis_c|$re_sjis_kana)/$s2e{$1}||&s2e($1)/geo;
&euc2euc(*_, $opt) if $opt;
$n;
}
sub s2e {
local($c1, $c2, $code);
($c1, $c2) = unpack('CC', $code = shift);
if (0xa1 <= $c1 && $c1 <= 0xdf) {
$c2 = $c1;
$c1 = 0x8e;
} elsif (0x9f <= $c2) {
$c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60);
$c2 += 2;
} else {
$c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61);
$c2 += 0x60 + ($c2 < 0x7f);
}
if ($cache) {
$s2e{$code} = pack('CC', $c1, $c2);
} else {
pack('CC', $c1, $c2);
}
}
;#
;# EUC to SJIS
;#
sub euc2sjis {
local(*_, $opt,$n) = @_;
&euc2euc(*_, $opt) if $opt;
$n = s/($re_euc_c|$re_euc_kana|$re_euc_0212)/$e2s{$1}||&e2s($1)/geo;
}
sub e2s {
local($c1, $c2, $code);
($c1, $c2) = unpack('CC', $code = shift);
if ($c1 == 0x8e) { # SS2
return substr($code, 1, 1);
} elsif ($c1 == 0x8f) { # SS3
return $undef_sjis;
} elsif ($c1 % 2) {
$c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71);
$c2 -= 0x60 + ($c2 < 0xe0);
} else {
$c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70);
$c2 -= 2;
}
if ($cache) {
$e2s{$code} = pack('CC', $c1, $c2);
} else {
pack('CC', $c1, $c2);
}
}
;#
;# JIS to JIS, SJIS to SJIS, EUC to EUC
;#
sub jis2jis {
local(*_, $opt) = @_;
s/$re_jis0208/$esc_0208/go;
s/$re_asc/$esc_asc/go;
&h2z_jis(*_) if $opt =~ /z/;
&z2h_jis(*_) if $opt =~ /h/;
}
sub sjis2sjis {
local(*_, $opt) = @_;
&h2z_sjis(*_) if $opt =~ /z/;
&z2h_sjis(*_) if $opt =~ /h/;
}
sub euc2euc {
local(*_, $opt) = @_;
&h2z_euc(*_) if $opt =~ /z/;
&z2h_euc(*_) if $opt =~ /h/;
}
;#
;# Cache control functions
;#
sub cache {
($cache, $cache = 1)[$[];
}
sub nocache {
($cache, $cache = 0)[$[];
}
sub flushcache {
undef %e2s;
undef %s2e;
}
;#
;# X0201 -> X0208 KANA conversion routine
;#
sub h2z_jis {
local(*_, $n) = @_;
if (s/$re_kana([^\e]*)/$esc_0208 . &_h2z_jis($1)/geo) {
1 while s/(($re_jis0208)[^\e]*)($re_jis0208)/$1/o;
}
$n;
}
sub _h2z_jis {
local($_) = @_;
$n += s/([\41-\137]([\136\137])?)/$h2z{$1}/g;
$_;
}
sub h2z_euc {
local(*_) = @_;
s/\216([\241-\337])(\216([\336\337]))?/$h2z{"$1$3"}/g;
}
sub h2z_sjis {
local(*_, $n) = @_;
s/(($re_sjis_c)+)|(([\241-\337])([\336\337])?)/
$1 || ($n++, $e2s{$h2z{$3}} || &e2s($h2z{$3}))/geo;
$n;
}
;#
;# X0208 -> X0201 KANA conversion routine
;#
sub z2h_jis {
local(*_, $n) = @_;
s/($re_jis0208)([^\e]+)/&_z2h_jis($2)/geo;
$n;
}
sub _z2h_jis {
local($_) = @_;
s/((\%[!-~]|![\#\"&VW+,<])+|([^!%][!-~]|![^\#\"&VW+,<])+)/&__z2h_jis($1)/ge;
$_;
}
sub __z2h_jis {
local($_) = @_;
return $esc_0208 . $_ unless /^%/ || /^![\#\"&VW+,<]/;
$n += length($_) / 2;
s/(..)/$z2h{$1}/g;
$esc_kana . $_;
}
sub z2h_euc {
local(*_, $n) = @_;
&init_z2h_euc unless defined %z2h_euc;
s/($re_euc_c|$re_euc_kana)/$z2h_euc{$1} ? ($n++, $z2h_euc{$1}) : $1/geo;
$n;
}
sub z2h_sjis {
local(*_, $n) = @_;
&init_z2h_sjis unless defined %z2h_sjis;
s/($re_sjis_c)/$z2h_sjis{$1} ? ($n++, $z2h_sjis{$1}) : $1/geo;
$n;
}
;#
;# Initializing JIS X0208 to X0201 KANA table for EUC and SJIS. This
;# can be done in &init but it's not worth doing. Similarly,
;# precalculated table is not worth to occupy the file space and
;# reduce the readability. The author personnaly discourages to use
;# X0201 Kana character in the any situation.
;#
sub init_z2h_euc {
local($k, $_);
s/([\241-\337])/\216$1/g && ($z2h_euc{$k} = $_) while ($k, $_) = each %z2h;
}
sub init_z2h_sjis {
local($_, $v);
/[\200-\377]/ && ($z2h_sjis{&e2s($_)} = $v) while ($_, $v) = each %z2h;
}
;#
;# TR function for 2-byte code
;#
sub tr {
# $prev_from, $prev_to, %table are persistent variables
local(*_, $from, $to, $opt) = @_;
local(@from, @to);
local($jis, $n) = (0, 0);
$jis++, &jis2euc(*_) if /$re_jp|$re_asc|$re_kana/o;
$jis++ if $to =~ /$re_jp|$re_asc|$re_kana/o;
if ($from ne $prev_from || $to ne $prev_to) {
($prev_from, $prev_to) = ($from, $to);
undef %table;
&_maketable;
}
s/([\200-\377][\000-\377]|[\000-\377])/
defined($table{$1}) && ++$n ? $table{$1} : $1/ge;
&euc2jis(*_) if $jis;
$n;
}
sub _maketable {
local($ascii) = '(\\\\[\\-\\\\]|[\0-\133\135-\177])';
&jis2euc(*to) if $to =~ /$re_jp|$re_asc|$re_kana/o;
&jis2euc(*from) if $from =~ /$re_jp|$re_asc|$re_kana/o;
grep(s/(([\200-\377])[\200-\377]-\2[\200-\377])/&_expnd2($1)/ge,$from,$to);
grep(s/($ascii-$ascii)/&_expnd1($1)/geo,$from,$to);
@to = $to =~ /[\200-\377][\000-\377]|[\000-\377]/g;
@from = $from =~ /[\200-\377][\000-\377]|[\000-\377]/g;
push(@to, ($opt =~ /d/ ? '' : $to[$#to]) x (@from - @to)) if @to < @from;
@table{@from} = @to;
}
sub _expnd1 {
local($_) = @_;
s/\\(.)/$1/g;
local($c1, $c2) = unpack('CxC', $_);
if ($c1 <= $c2) {
for ($_ = ''; $c1 <= $c2; $c1++) {
$_ .= pack('C', $c1);
}
}
$_;
}
sub _expnd2 {
local($_) = @_;
local($c1, $c2, $c3, $c4) = unpack('CCxCC', $_);
if ($c1 == $c3 && $c2 <= $c4) {
for ($_ = ''; $c2 <= $c4; $c2++) {
$_ .= pack('CC', $c1, $c2);
}
}
$_;
}
1;
version 1.20
by yav