WeB DoRaMa Plus
をテンプレートにして作成
[
トップ
] [
新規
|
一覧
|
検索
|
最終更新
|
ヘルプ
]
開始行:
[[WeB DoRaMaシリーズ]]
#contents
#norelated
#br
* WeB DoRaMa Plusスクリプト保管庫 [#rddf62de]
** 本来であればKEEP OUTの代物であるが… [#pc0764dd]
私は資料としてこのスクリプトを公開展示する。~
文句があっても口に出すな…
展示する理由、それは、もう配布されていないのと技術的資料...
** Script [#v60d3a83]
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
#!/usr/local/bin/perl
# WeB DoRaMa version 1.11
# Script written by Shigeto Nakazawa.(1996/11/27)
# This script is free.
# Arranged by Ninjinju-su CGI
require './jcode.pl';
# ---------------------------------
# 各種設定
# ---------------------------------
$max = '150'; # 登録・表示最大数(あまり...
$view = 5; # 初期画面で表示する数
$backurl = '../'; # 帰りのURL(変更してく...
$mojicode = 'sjis'; # Windows なら 'sjis' UNI...
$logfile = 'dorama.log'; # 記録用ファイル
$lockfile = 'dorama.lock'; # 鍵ファイル
$lockcheck = 1; # 鍵ファイルの使用(通常は...
$pluscheck = 1; # 登場人物設定(1:自由登録...
$kyaralogfile = 'kyara.log'; # 登場人物記録用ファイル
$type = '<>'; #ログ形式設定
# ---------------------------------
# フォームからデータをもらう
# ---------------------------------
if ($ENV{'REQUEST_METHOD'} eq "POST") { read(STDIN, $buf...
$typec = $type;
$typec =~ s/\\//;
@pairs = split(/&/,$buffer);
foreach $pair (@pairs) {
($name,$value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex(...
&jcode'convert(*value,$mojicode);
$value =~ s/\n//;
if ($type ne '<>') {
$value =~ s/$typec//;
}
$value =~ s/<(.|\n)*//g;
$FORM{$name} = $value;
}
# ---------------------------------
# HTML出力
# ---------------------------------
print <<"_HTML_header_";
Content-type: text/html\n\n
<!--
WeB DoRaMa は WeB BaNaNa を元に改良したおかぴ@関大さ...
ユニークなので、アイデアをいただき配布することにしまし...
おかぴさん(アイデア): http://www.cmlab.densi.kansai...
じゃわ(著作権) : http://www3.osk.3web.ne.jp/~j...
-->
<HTML>
<HEAD>
<TITLE> WeB DoRaMa Plus </TITLE>
</HEAD>
<BODY BGCOLOR="#FFEFE3" TEXT="#4F4F4F" LINK="#7979FF" VL...
_HTML_header_
# ---------------------------------
# 記録ファイルを読み込む
# ---------------------------------
if ($lockcheck) {
$wt = 0;
while (-f $lockfile) {
$wt++;
if ($wt > 19) {
&error('強制終了されました。処理は中断されま...
}
sleep 1;
}
open (LOCK,">$lockfile");
}
if (!open(IN,$logfile)) {
unlink ($lockfile);
&error("管理者が記録ファイルの読み込みを許可していま...
}
@lines = <IN>;
close(IN);
if (!open(IN,$kyaralogfile)) {
unlink ($lockfile);
&error("管理者が登場人物記録ファイルの読み込みを許可...
}
@tomatos = <IN>;
close(IN);
unlink ($lockfile);
foreach $tomato (@tomatos) {
chop($tomato);
($kyara,$color) = split(/$type/, $tomato);
$kyara = &change1($kyara);
push(@actors,$kyara);
push(@colors,$color);
}
if ($pluscheck) {
$plusok = "<SMALL>[<A HREF=\"doraedit.cgi?plus=0\">...
}
# ---------------------------------
# 分岐
# ---------------------------------
if ($buffer eq '') {
&html;
} else {
®ist;
}
exit;
# *************
# ウェルカム!
# *************
sub html {
print <<"_HTML_top_";
<CENTER>
<H1><I>WeB DoRaMa Plus</I></H1>
<HR>
小説は事実より奇なり。読みたい人は自分も小説を書きましょ...
<BR><BR><BR>
</CENTER><BLOCKQUOTE>
_HTML_top_
for ($i=$view-1;$i>-1;$i--) {
($nn,$date,$dorama,$actor) = split(/$type/, $lin...
$dorama_c = &change1($dorama);
print "<FONT SIZE=+2 COLOR=\"$colors[$actor]\">$...
if (!$i) { $no = $nn; }
}
print <<"_HTML_middle_";
</BLOCKQUOTE><CENTER>
<BR><BR><BR>
<FORM METHOD="post" ACTION="dorama.cgi">
<INPUT TYPE="hidden" NAME="no" VALUE="$no">
_HTML_middle_
print "<SELECT NAME=\"actor\">\n";
print "<OPTION VALUE=\"no\">誰のセリフか選んでね!\n";
for ($i=$#actors;$i>=0;$i--) {
if ($colors[$i] ne 'del') {
print "<OPTION VALUE=\"$i\">$actors[$i]\n";
}
}
print "</SELECT>\n";
print <<"_HTML_buttom_";
<INPUT TYPE=text NAME="dorama" SIZE="50" MAXLENGTH="300"...
<INPUT TYPE=submit VALUE="これでよい(Ok)">
<INPUT TYPE=reset VALUE="消す(Clear)">
</FORM>
</CENTER>
<FONT SIZE=-1 COLOR="#FF0000">
<LI>同じ人物が続けて発言することはできません。
<LI>タグを使用したり、<B>全角150字</B>を超えると登録...
</FONT>
<P>
$plusok
<SMALL>[<A HREF="doraedit.cgi">管理用</A>]</SMALL>
<!-- 著作権表示 (必ず表示してください。) -->
<DIV ALIGN="right"><TT>
WeB DoRaMa v1.11 [<A HREF="http://www3.osk.3web.ne.jp/~j...
WeB DoRaMa Plus v1.0 [<A HREF="http://www.micnet.or.jp/k...
</TT></DIV>
</BODY></HTML>
_HTML_buttom_
}
# *************
# 登録
# *************
sub regist {
$no = $FORM{'no'};
$actor = $FORM{'actor'};
$dorama = $FORM{'dorama'};
$dorama_c = &change0($FORM{'dorama'});
# ---------------------------------
# フォームセキュリチー
# ---------------------------------
($ck_no,$date,$ck_dorama,$ck_actor) = split(/$type/, $li...
if ($ck_no ne $no) {
&error("残念、タイムオーバーです。すでに、誰かが執筆...
}
if ($ck_actor == $actor) {
&error("同じ人がセリフを言ってはいけません。");
}
if ($colors[$actor] eq 'no') {
&error("セリフを言う人を選んでください。");
}
if ($colors[$actor] eq 'del') {
&error("削除されていますので使えません");
}
if ($dorama eq '') {
&error("何も書かれていないか、または使用禁止の文字が...
}
if (length($dorama) >= 300) {
&error("言葉が長すぎます。文字数は全角150字を超え...
}
# ----------------------------------
# 日付を取得する
# ----------------------------------
($sec,$min,$hour,$day,$mon) = localtime(time);
$mon++;
if ($sec < 10) { $sec = "0$sec"; }
if ($min < 10) { $min = "0$min"; }
if ($hour < 10) { $hour = "0$hour"; }
if ($day < 10) { $day = "0$day"; }
if ($mon < 10) { $mon = "0$mon"; }
$date = "$mon/$day $hour:$min:$sec";
# ---------------------------------
# HTML出力
# ---------------------------------
print <<"_HTML_thanks_";
<CENTER><H1><I>WeB DoRaMa Plus</I></H1>
<IMG SRC="dorama.gif"></CENTER><P>
執筆ありがとう!(^o^)<BR>
ゆっくりご覧下さい。見終わったら、<A HREF="$backurl">こ...
<CENTER><IMG SRC="dorama.gif"></CENTER>
<P>
<SMALL>[<A HREF="dorama.cgi?">もどる</A>]</SMALL><br>
_HTML_thanks_
$i = 0;
$no = ($no + 1) % 9999;
@new = '';
unshift(@lines,"$no$typec$date$typec$dorama_c$typec$acto...
foreach $line (@lines) {
$i++;
push(@new,$line);
if ($i == $max) { last; }
}
for ($i=@new-1;$i>0;$i--) {
($no,$date,$dorama,$actor) = split(/$type/,$new[$i]);
$dorama_c = &change1($dorama);
print "<SMALL><FONT COLOR=\"green\">$date</FONT></SM...
}
# ---------------------------------
# 記録ファイルに登録する
# ---------------------------------
if ($lockcheck) {
$wt = 0;
while (-f $lockfile) {
$wt++;
if ($wt > 19) {
&error('強制終了されました。処理は中断されま...
}
sleep 1;
}
open (LOCK,">$lockfile");
}
if (!open(OUT,">$logfile")) {
unlink ($lockfile);
&error("管理者が記録用ファイルの書き込みを許可してい...
}
print OUT @new;
close(OUT);
unlink ($lockfile);
}
# ***************************
# 禁止文字コードの変換処理
# ***************************
sub change0 {
local($text) = $_[0];
$text =~ s/\(/(/g;
$text =~ s/\)/)/g;
$text =~ s/\*/*/g;
$text =~ s/\+/+/g;
$text =~ s/\././g;
$text =~ s/\?/?/g;
$text =~ s/\[/[/g;
$text =~ s/\\/\/g;
$text =~ s/\]/]/g;
$text =~ s/\{/{/g;
$text =~ s/\|/|/g;
$text =~ s/\}/}/g;
return $text;
}
sub change1 {
local($text) = $_[0];
$text =~ s/(/\(/g;
$text =~ s/)/\)/g;
$text =~ s/*/\*/g;
$text =~ s/+/\+/g;
$text =~ s/./\./g;
$text =~ s/?/\?/g;
$text =~ s/[/\[/g;
$text =~ s/\/\\/g;
$text =~ s/]/\]/g;
$text =~ s/{/\{/g;
$text =~ s/|/\|/g;
$text =~ s/}/\}/g;
return $text;
}
# ***************************
# エラー処理
# ***************************
sub error {
print <<"_HTML_error_";
<H2>監督<FONT COLOR="red">『カット!!』</FONT></H2>
$_[0]
</BODY></HTML>
_HTML_error_
exit;
}
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
#!/usr/local/bin/perl
# WeB dorama Editor version 1.11
#
# Script written by Shigeto Nakazawa.(1996/11/27)
# This script is free.
# Arranged by Ninjinju-su CGI
require './jcode.pl';
# ---------------------------------
# 各種設定
# ---------------------------------
$pass = 'password'; # 必ず半角英数8文字以内で...
$mojicode = 'sjis'; # Windows なら 'sjis' UNI...
$logfile = 'dorama.log'; # 記録用ファイル
$lockfile = 'dorama.lock'; # 鍵ファイル
$lockcheck = 1; # 鍵ファイルの使用(通常は...
$pluscheck = 1; # 登場人物設定(1:自由登録...
$kyaralogfile = 'kyara.log'; # 登場人物記録用ファイル
@plus_colors = ('#000000=くろ',
'#FF0000=あか',
'#008000=みどり',
'#0000FF=あお',
'#00FFFF=みずいろ',
'#FF8000=みかん',
'#804000=ちゃ',
'#00C0C0=まりんぶるー',
'#FF8080=もも',
'#808080=ねずみ'); # 登場人物につける色
$type = '<>'; #ログ形式設定
# ---------------------------------
# フォームからデータをもらう
# ---------------------------------
if ($ENV{'REQUEST_METHOD'} eq "POST") { read(STDIN, $buf...
$typec = $type;
$typec =~ s/\\//;
@pairs = split(/&/,$buffer);
foreach $pair (@pairs)
{
($name,$value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex(...
&jcode'convert(*value,$mojicode);
$value =~ s/\n//;
if ($type ne '<>') {
$value =~ s/$typec//;
}
if ($value ne 'on') {
$FORM{$name} = $value;
} else {
$FORM{$name} = 1;
}
}
$rq_dorama = &change0($FORM{'dorama'});
$rq_actor = &change0($FORM{'actor'});
$pw = $FORM{'pass'};
$typec = $type;
$typec =~ s/\\//;
# ---------------------------------
# HTML出力
# ---------------------------------
print <<"_HTML_header_";
Content-type: text/html\n\n
<HTML><HEAD><TITLE> WeB DoRaMa Editor Plus </TITLE></HEAD>
<BODY BGCOLOR="#FFEFE3" text="#4F4F4F" link="#7979FF" vl...
_HTML_header_
# ---------------------------------
# 記録ファイルを読み込む
# ---------------------------------
if ($lockcheck) {
local($wt) = 0;
while (-f $lockfile) {
if (++$wt > 5) {
&error('強制終了されました。処理は中断されま...
}
sleep 4;
}
open (LOCK,">$lockfile");
}
if (!open(IN,$logfile)) {
unlink ($lockfile);
&error("記録ファイルの読み込みに失敗しました。");
}
@lines = <IN>;
close(IN);
if (!open(IN,$kyaralogfile)) {
unlink ($lockfile);
&error("登場人物記録ファイルの読み込みに失敗しました...
}
@tomatos = <IN>;
close(IN);
unlink ($lockfile);
@ptomatos = @tomatos;
foreach $tomato (@tomatos) {
chop($tomato);
($kyara,$color) = split(/$type/, $tomato);
$kyara = &change1($kyara);
push(@actors,$kyara);
push(@colors,$color);
}
if ($pw eq $pass) {
$back = "doraedit.cgi?pass=$pw";
} else {
$back = "dorama.cgi";
}
# ---------------------------------
# plusのみ分岐
# ---------------------------------
if ($FORM{'plus'} eq '0' && $pluscheck || $pass eq $pw &...
+
} elsif ($FORM{'plus'} eq '1' && $pluscheck || $pass eq ...
&pluss;
} elsif ($pass eq $pw && $FORM{'plus'} eq '2') {
&plusedit;
} elsif ($pass eq $pw && $FORM{'plus'} eq '3') {
&plusregist;
}
# ---------------------------------
# パスワードのチェック
# ---------------------------------
if ($pass ne $pw) {
print <<"_HTML_password_";
<HR>
<CENTER>
パスワード
<FORM ACTION="doraedit.cgi" METHOD="post">
<INPUT TYPE="password" NAME="pass" SIZE=10>
<INPUT TYPE="submit" VALUE="おっけー">
</FORM>
</CENTER>
<HR>
_HTML_password_
exit;
}
# ---------------------------------
# 編集処理
# ---------------------------------
($new_no) = split(/$type/,$lines[0]);
$new_no = ($new_no + 1) % 9999;
foreach $line (@lines) {
($no,$date) = split(/$type/,$line);
if ($FORM{$no} == 1) {
$check = 1;
if ($rq_dorama ne '') {
$line = "$no$typec$date$typec$rq_dorama$type...
push (@new,$line);
}
} else {
push (@new,$line);
}
}
# ---------------------------------
# 記録ファイルに書き込む
# ---------------------------------
if ($check) {
($no,$date,$dorama,$actor) = split(/$type/,$new[0]);
$new[0] = "$new_no$typec$date$typec$dorama$typec$act...
if ($lockcheck) {
local($wt) = 0;
while (-f $lockfile) {
if (++$wt > 5) {
&error('強制終了されました。処理は中断さ...
}
sleep 4;
}
open (LOCK,">$lockfile");
}
if (!open(OUT,">$logfile")) {
unlink ($lockfile);
&error("記録ファイルの書き込みに失敗しました。");
}
print OUT @new;
close(OUT);
unlink ($lockfile);
}
# ---------------------------------
# リストを表示
# ---------------------------------
print <<"_EOF_";
<CENTER>
<H2><I>WeB dorama Editor Plus</I></H2>
</CENTER>
<P>
<FONT COLOR="#FF0000">★使い方★</FONT>
<BR>
<FONT SIZE=-1><OL>
<LI>編集する項目をチェックします
<LI>編集内容を書きます(このとき、何も書かなかった場合、...
<LI>[編集開始]で書き換えられます。
</OL></FONT>
<P>
<CENTER>
<FORM ACTION="doraedit.cgi" method="post">
<INPUT TYPE="hidden" NAME="pass" VALUE="$pw">
_EOF_
print "<SELECT NAME=\"actor\">\n";
print "<OPTION VALUE=\"no\">誰のセリフか選んでね!\n";
for ($i=$#actors;$i>=0;$i--) {
if ($colors[$i] ne 'del') {
print "<OPTION VALUE=\"$i\">$actors[$i]\n";
}
}
print "</SELECT>\n";
print <<"_EOF_";
<INPUT TYPE="text "NAME="dorama" SIZE="50">
<INPUT TYPE="submit" VALUE="編集開始"><BR>
</CENTER>
<SMALL>[<FONT COLOR="#0000FF">登場人物<A HREF="doraedit....
<SMALL>[<A HREF="dorama.cgi">ドラマ</A>]</SMALL>
<HR>
_EOF_
foreach $line (@new) {
($no,$date,$dorama,$actor) = split(/$type/,$line);
$dorama = &change1($dorama);
print "<INPUT TYPE=\"checkbox\" NAME=\"$no\">\n";
print "<FONT SIZE=-1 COLOR=#FF0000>$date</FONT> : ";
print "<FONT SIZE=+1 COLOR=#CC0000>$actors[$actor]</...
print "『<FONT SIZE=+1 COLOR=#0000CC>$dorama</FONT>...
}
# ***************************
# 登場人物編集
# ***************************
# ---------------------------------
# 登場人物追加フォーム
# ---------------------------------
sub plus {
print <<"_EOF_";
<CENTER>
<H1><I>WeB DoRaMa Plus</I></H1>
<HR>
あなたも小説に登場人物を追加したいはず!ということで・・・
<BR><BR><BR>
<FORM METHOD="post" ACTION="doraedit.cgi">
<INPUT TYPE="hidden" NAME="plus" VALUE="1">
<INPUT TYPE="hidden" NAME="pass" VALUE="$pw">
_EOF_
print "色:<SELECT NAME=\"color\">\n";
foreach $plus_color (@plus_colors) {
($code,$color_name) = split(/=/, $plus_color);
print "<OPTION VALUE=\"$code\">$color_name\n";
}
print "</SELECT> \n";
print <<"_HTML_";
人物名:<INPUT TYPE=text NAME="name" SIZE="50" MAXLENGTH...
<INPUT TYPE=submit VALUE="これでよい(Ok)">
<INPUT TYPE=reset VALUE="消す(Clear)">
</FORM>
</CENTER>
<FONT SIZE=-1 COLOR="#FF0000">
<LI>変な登場人物名は入れないでください
<LI>タグを使用したり、<B>全角20字</B>を超えると登録さ...
</FONT>
<P>
<SMALL>[<A HREF="$back">もどる</A>]</SMALL>
_HTML_
exit;
}
# ---------------------------------
# 登場人物名登録
# ---------------------------------
sub pluss {
$color = $FORM{'color'};
$name = $FORM{'name'};
$name_c = &change0($name);
if ($name eq '') {
&error("何も書かれていないか、または使用禁止の文字が...
}
if (length($name) >= 40) {
&error("名前が長すぎます。文字数は全角20字を超えて...
}
# ---------------------------------
# 登場人物専用記録ファイルに登録する
# ---------------------------------
if ($lockcheck) {
$wt = 0;
while (-f $lockfile) {
$wt++;
if ($wt > 19) {
&error('強制終了されました。処理は中断されま...
}
sleep 1;
}
open (LOCK,">$lockfile");
}
if (!open(OUT,">>$kyaralogfile")) {
unlink ($lockfile);
&error("管理者が登場人物記録用ファイルの書き込みを許...
}
print OUT "$name_c$typec$color\n";
close(OUT);
unlink ($lockfile);
print <<"_EOF_";
<CENTER>
<H1><I>WeB DoRaMa<br>Plus</I></H1>
<HR>
あなたが登場させたい人物の名前が追加されました
<BR><BR><BR>
<H2><FONT COLOR="$color"><B>『$name』</B></FONT>が追加さ...
</CENTER>
<P>
<SMALL>[<A HREF="$back">もどる</A>]</SMALL>
_EOF_
exit;
}
# ---------------------------------
# 登場人物編集フォーム
# ---------------------------------
sub plusedit {
print <<"_EOF_";
<CENTER>
<H1><I>WeB DoRaMa Plus Editor</I></H1>
</CENTER>
<HR>
<P>
<FONT COLOR="#FF0000">★使い方★</FONT>
<BR>
<FONT SIZE=-1><OL>
<LI>編集したいを登場人物名を選びます
<LI>登場人物の色や名前を書き換えたりします
<DD>(このとき、色の中の削除を選んだ場合、削除されます)
<DD>(削除したものも編集可能です)
<LI>[編集開始]で書き換えられます。
</OL></FONT>
<P>
<CENTER>
<FORM METHOD="post" ACTION="doraedit.cgi">
<INPUT TYPE="hidden" NAME="plus" VALUE="3">
<INPUT TYPE="hidden" NAME="pass" VALUE="$pw">
_EOF_
print "編集人物:<SELECT NAME=\"actor_p\">\n";
for ($i=0;$i<@actors;$i++) {
print "<OPTION VALUE=\"$i\">$actors[$i]\n";
}
print "</SELECT>\n";
print "色:<SELECT NAME=\"color_p\">\n";
foreach $plus_color (@plus_colors) {
($code,$color_name) = split(/=/, $plus_color);
print "<OPTION VALUE=\"$code\">$color_name\n";
}
print "<OPTION VALUE=\"del\">削除\n";
print "</SELECT> \n";
print <<"_HTML_";
人物名:<INPUT TYPE=text NAME="name" SIZE="50" MAXLENGTH...
<INPUT TYPE=submit VALUE="編集開始">
<INPUT TYPE=reset VALUE="編集取消">
</FORM>
</CENTER>
<FONT SIZE=-1 COLOR="#FF0000">
<LI>タグを使用したり、<B>全角20字</B>を超えると登録さ...
</FONT>
<P>
<SMALL>[<A HREF="doraedit.cgi?pass=$pw">もどる</A>]</SMA...
_HTML_
exit;
}
sub plusregist {
$color = $FORM{'color_p'};
$actor = $FORM{'actor_p'};
$name = $FORM{'name'};
$name_c = &change0($name);
if ($color eq 'del') {
$name = $mes = "削除";
} else {
$mes = "<FONT COLOR=\"$color\"><B>『$name』</B></FON...
}
if ($actor eq '' || $color eq '') {
&error("編集人物名または色が選ばれていません");
}
if ($name eq '' && $color ne 'no') {
&error("何も書かれていないか、または使用禁止の文字が...
}
if (length($name) >= 40) {
&error("名前が長すぎます。文字数は全角20字を超えて...
}
$sio = 0;
foreach $line (@ptomatos) {
if ($sio eq $actor) {
$line = "$name_c$typec$color\n";
push (@ptomato,$line);
} else {
push (@ptomato,$line);
}
$sio++;
}
# ---------------------------------
# 登場人物記録ファイルに登録する
# ---------------------------------
if ($lockcheck) {
$wt = 0;
while (-f $lockfile) {
$wt++;
if ($wt > 19) {
&error('強制終了されました。処理は中断されま...
}
sleep 1;
}
open (LOCK,">$lockfile");
}
if (!open(OUT,">$kyaralogfile")) {
unlink ($lockfile);
&error("登場人物記録ファイルの書き込みに失敗しました...
}
print OUT @ptomato;
close(OUT);
unlink ($lockfile);
print <<"_EOF_";
<CENTER>
<H1><I>WeB DoRaMa<br>Plus Editor</I></H1>
<HR>
みごと編集が完了されましたわよ。
<BR><BR><BR>
<H2><FONT COLOR="$colors[$actor]"><B>『$actors[$actor]』...
</CENTER>
<P>
<SMALL>[<A HREF="doraedit.cgi?pass=$pw">もどる</A>]</SMA...
_EOF_
exit;
}
# ***************************
# 禁止文字コードの変換処理
# ***************************
sub change0 {
local($text) = $_[0];
$text =~ s/\(/(/g;
$text =~ s/\)/)/g;
$text =~ s/\*/*/g;
$text =~ s/\+/+/g;
$text =~ s/\././g;
$text =~ s/\?/?/g;
$text =~ s/\[/[/g;
$text =~ s/\\/\/g;
$text =~ s/\]/]/g;
$text =~ s/\{/{/g;
$text =~ s/\|/|/g;
$text =~ s/\}/}/g;
return $text;
}
sub change1 {
local($text) = $_[0];
$text =~ s/(/\(/g;
$text =~ s/)/\)/g;
$text =~ s/*/\*/g;
$text =~ s/+/\+/g;
$text =~ s/./\./g;
$text =~ s/?/\?/g;
$text =~ s/[/\[/g;
$text =~ s/\/\\/g;
$text =~ s/]/\]/g;
$text =~ s/{/\{/g;
$text =~ s/|/\|/g;
$text =~ s/}/\}/g;
return $text;
}
# ***************************
# エラー処理
# ***************************
sub error {
print <<"_HTML_error_";
<H2>エラーが発生しました。</H2>
$_[0]
</BODY></HTML>
_HTML_error_
exit;
}
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
A夫<>#0000FF
B子<>#FF0000
C助<>#008800
D美<>#FF0000
ナレーション<>#000000
効果音<>#008000
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
package jcode;
;#######################################################...
;#
;# jcode.pl: Perl library for Japanese character code co...
;#
;# Copyright (c) 1995,1996 Kazumasa Utashiro <utashiro@i...
;# Internet Initiative Japan Inc.
;# 1-4 Sanban-cho, Chiyoda-ku, Tokyo 102, Japan
;#
;# Copyright (c) 1992,1993,1994 Kazumasa Utashiro
;# Software Research Associates, Inc.
;# Original by srekcah@sra.co.jp, Feb 1992
;#
;# Redistribution for any purpose, without significant m...
;# is granted as long as all copyright notices are retai...
;# SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY ...
;# IMPLIED WARRANTIES ARE DISCLAIMED.
;#
;; $rcsid = q$Id: jcode.pl,v 2.0 1996/10/02 16:02:38 uta...
;#
;#######################################################...
;#
;# 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.
;#
;# Code detection between euc and sjis is very difficult
;# or sometimes impossible or even lead to wrong result
;# when it's include JIS X0201 KANA characters. So JIS
;# X0201 KANA is ignored for automatic code detection.
;#
;# &jcode'convert(*line, $ocode [, $icode [, $option]])
;# Convert the line in any Japanese code to the specified
;# code 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.
;# See above). $icode also can be specified, but xxx2yyy
;# routine is more efficient when both codes are known.
;#
;# It returns a list of pointer of convert subroutine and
;# input code. It means that this routine returns the
;# input code of the line in scalar context.
;#
;# 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().
;#
;# &to($ocode, $line [, $icode [, $option]])
;# &jis($line [, $icode [, $option]])
;# &euc($line [, $icode [, $option]])
;# &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 added as a prefix
;# 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. This
;# funciton is under construction and doesn't have full
;# feature of tr. Range operator like a-z is partially
;# supported: JIS or EUC and first byte should be same on
;# first and last character (so HIRAGANA-KATAKANA
;# conversion is possible). Only 'd' is interpreted as
;# option.
;#
;# &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 other functions. You
;# don't have to call this when using jocde.pl by do or
;# require. Call it first if you embedded the jcode.pl
;# in your script.
;#
;#######################################################...
;#
;# SAMPLES
;#
;# Convert any Kanji code to JIS and print each line wit...
;#
;# while (<>) {
;# $code = &jcode'convert(*_, 'jis');
;# print $code, "\t", $_;
;# }
;#
;# Convert all lines to JIS according to the first recog...
;#
;# 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(@readahead, $_);
;# next unless $code;
;# eval "&jcode'${code}2jis(*_), print while (\$_ = ...
;# eval "&jcode'${code}2jis(*_), print while (\$_ = ...
;# last;
;# }
;#
;#######################################################...
;#
;# Call initialize function if it is not called yet. Th...
;# strange but it makes easy to embed the jcode.pl at th...
;# script. Call &jcode'init at the beginning of the scr...
;# case.
;#
&init unless defined $version;
;#
;# Initialize variables.
;#
sub init {
$version = $rcsid =~ /,v ([\d.]+)/ ? $1 : 'unkown';
$re_bin = '[\000-\006\177\377]';
$re_jp = '\e\$[\@B]';
$re_asc = '\e\([BJ]';
$re_kana = '\e\(I';
($esc_jp, $esc_asc, $esc_kana) = ("\e\$B", "\e(B", "...
$re_sjis_c = '[\201-\237\340-\374][\100-\176\200-\37...
$re_sjis_kana = '[\241-\337]';
$re_euc_c = '[\241-\376][\241-\376]';
$re_euc_kana = '\216[\241-\337]';
# These variables are retained only for backward com...
$re_euc_s = "($re_euc_c)+";
$re_sjis_s = "($re_sjis_c)+";
$cache = 1;
# X0201 -> X0208 KANA conversion table. Looks weird...
# much. This is simply JIS text without escape sequ...
($h2z_high = $h2z = <<'__TABLE_END__') =~ tr/\021-\1...
! !# $ !" % !& " !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;
$_ = '';
for $f ('jis', 'sjis', 'euc') {
for $t ('jis', 'sjis', 'euc') {
$_ .= "\$convf{'$f', '$t'} = *${f}2${t};\n";
}
$_ .= "\$h2zf{'$f'} = *h2z_${f};\n\$z2hf{'$f'} = *z2h_$...
}
eval $_;
}
;#
;# Set escape sequences which should be put before and a...
;# (JIS X0208) string.
;#
sub jis_inout {
$esc_jp = shift || $esc_jp;
$esc_jp = "\e\$$esc_jp" if length($esc_jp) == 1;
$esc_asc = shift || $esc_asc;
$esc_asc = "\e\($esc_asc" if length($esc_asc) == 1;
($esc_jp, $esc_asc);
}
;#
;# Get JIS in and out sequences from the string.
;#
sub get_inout {
local($esc_jp, $esc_asc);
$_[$[] =~ /$re_jp/o && ($esc_jp = $&);
$_[$[] =~ /$re_asc/o && ($esc_asc = $&);
($esc_jp, $esc_asc);
}
;#
;# Recognize character code.
;#
sub getcode {
local(*_) = @_;
return undef unless /[\e\200-\377]/;
return 'jis' if /$re_jp|$re_asc|$re_kana/o;
return 'binary' if /$re_bin/o;
local($sjis, $euc);
$sjis += length($&) while /($re_sjis_c)+/go;
$euc += length($&) while /($re_euc_c)+/go;
(&max($sjis, $euc), ('euc', undef, 'sjis')[($sjis<=>...
}
sub max { $_[ $[ + ($_[$[] < $_[$[+1]) ]; }
;#
;# Convert any code to specified code.
;#
sub convert {
local(*_, $ocode, $icode, $opt) = @_;
return (undef, undef) unless $icode = $icode || &get...
return (undef, $icode) if $icode eq 'binary';
$ocode = 'jis' unless $ocode;
$ocode = $icode if $ocode eq 'noconv';
local(*convf) = $convf{$icode, $ocode};
do convf(*_, $opt);
(*convf, $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;
if (s/($re_sjis_kana)+|($re_sjis_c)+/&_sjis2jis($&)/...
s/$re_asc($re_jp|$re_kana)/$1/go;
}
$n;
}
sub _sjis2jis {
local($_) = @_;
if (/^$re_sjis_kana/o) {
$n += tr/\241-\337/\041-\137/;
$esc_kana . $_ . $esc_asc;
} else {
$n += s/$re_sjis_c/$s2e{$&}||&s2e($&)/geo;
tr/\241-\376/\041-\176/;
$esc_jp . $_ . $esc_asc;
}
}
;#
;# EUC to JIS
;#
sub euc2jis {
local(*_, $opt, $n) = @_;
&euc2euc(*_, $opt) if $opt;
if (s/($re_euc_kana)+|($re_euc_c)+/&_euc2jis($&)/geo...
s/$re_asc($re_jp|$re_kana)/$1/go;
}
$n;
}
sub _euc2jis {
local($_) = @_;
local($esc) = tr/\216//d ? $esc_kana : $esc_jp;
$n += tr/\241-\376/\041-\176/;
$esc . $_ . $esc_asc;
}
;#
;# JIS to EUC
;#
sub jis2euc {
local(*_, $opt, $n) = @_;
s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2euc($1,$2)...
&euc2euc(*_, $opt) if $opt;
$n;
}
sub _jis2euc {
local($esc, $_) = @_;
if ($esc !~ /$re_asc/o) {
$n += tr/\041-\176/\241-\376/;
s/[\241-\337]/\216$&/g if $esc =~ /$re_kana/o;
}
$_;
}
;#
;# JIS to SJIS
;#
sub jis2sjis {
local(*_, $opt, $n) = @_;
&jis2jis(*_, $opt) if $opt;
s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2sjis($1,$2...
$n;
}
sub _jis2sjis {
local($esc, $_) = @_;
if ($esc !~ /$re_asc/o) {
$n += tr/\041-\176/\241-\376/;
s/$re_euc_c/$e2s{$&}||&e2s($&)/geo if $esc =~ /$re_jp/o;
}
$_;
}
;#
;# SJIS to EUC
;#
sub sjis2euc {
local(*_, $opt,$n) = @_;
$n = s/$re_sjis_kana|$re_sjis_c/$s2e{$&}||&s2e($&)/g...
&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/$e2s{$&}||&e2s($&)/geo;
}
sub e2s {
local($c1, $c2, $code);
($c1, $c2) = unpack('CC', $code = shift);
if ($c1 == 0x8e) {
return substr($code, 1, 1);
} 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_jp/$esc_jp/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_jp . &_h2z_jis($1)/geo) {
1 while s/($re_jp[^\e]*)$re_jp/$1/o;
}
$n;
}
sub _h2z_jis {
local($_) = @_;
$n += s/[\41-\137]([\136\137])?/$h2z{$&}/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_jp([^\e]+)/&_z2h_jis($1)/geo;
$n;
}
sub _z2h_jis {
local($_) = @_;
s/(\%[!-~]|![\#\"&VW+,<])+|([^!%][!-~]|![^\#\"&VW+,<...
$_;
}
sub __z2h_jis {
local($_) = @_;
return $esc_jp . $_ unless /^%/ || /^![\#\"&VW+,<]/;
$n += length($_) / 2;
s/../$z2h{$&}/g;
$esc_kana . $_;
}
sub z2h_euc {
local(*_, $n) = @_;
&init_z2h_euc unless defined %z2h_euc;
s/$re_euc_c|$re_euc_kana/$z2h_euc{$&} ? ($n++, $z2h_...
$n;
}
sub z2h_sjis {
local(*_, $n) = @_;
&init_z2h_sjis unless defined %z2h_sjis;
s/$re_sjis_c/$z2h_sjis{$&} ? ($n++, $z2h_sjis{$&}) :...
$n;
}
;#
;# Initializing JIS X0208 to X0201 KANA table for EUC an...
;# can be done in &init but it's not worth doing. Simil...
;# precalculated table is not worth to occupy the file s...
;# reduce the readability. The author personnaly discou...
;# X0201 Kana character in the any situation.
;#
sub init_z2h_euc {
local($k, $_);
s/[\241-\337]/\216$&/g && ($z2h_euc{$k} = $_) while ...
}
sub init_z2h_sjis {
local($_, $v);
/[\200-\377]/ && ($z2h_sjis{&e2s($_)} = $v) while ($...
}
;#
;# TR function for 2-byte code
;#
sub tr {
local(*_, $from, $to, $opt) = @_;
local(@from, @to, %table);
local($jis, $n) = (0, 0);
local($ascii) = '(\\\\[\\-\\\\]|[\0-\133\135-\177])';
&jis2euc(*_), $jis++ if $_ =~ /$re_jp/o;
&jis2euc(*to), $jis++ if $to =~ /$re_jp/o;
&jis2euc(*from) if $from =~ /$re_jp/o;
grep(s/([\200-\377])[\200-\377]-\1[\200-\377]/&_expn...
grep(s/$ascii-$ascii/&_expnd1($&)/geo, $from, $to);
@to = $to =~ /[\200-\377][\000-\377]|[\000-\377]...
@from = $from =~ /[\200-\377][\000-\377]|[\000-\377]...
push(@to, ($opt =~ /d/ ? '' : $to[$#to]) x (@from - ...
@table{@from} = @to;
s/[\200-\377][\000-\377]|[\000-\377]/
defined($table{$&}) && ++$n ? $table{$&} : $&/ge;
&euc2jis(*_) if $jis;
$n;
}
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;
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
&ref(http://webdoramamuseum.s1003.xrea.com/common/img/cgi...
** File [#q41e61ea]
とりあえず代理で配布する。~
Perlをかじった上で触れたことがある者なら何が不足している...
登場人物にHTMLタグが登録されると言う脆弱性により書き込め...
~
CENTER:それでもよければダウンロードしてもいい…
- [[&ref(http://webdoramamuseum.s1003.xrea.com/common/img...
[[&ref(http://webdoramamuseum.s1003.xrea.com/common/img/d...
CENTER:もし設置する場合は…
dorama.cgi [755|705|700]~
doraedit.cgi [755|705|700]~
kyara.log [666|606|600]~
dorama.log [666|606|600]~
jcode.pl [644|606|600]~
dorama.gif [644]~
** 体験版 [#v915f6f8]
[[体験版>http://webdoramamuseum.s1003.xrea.com/cgi-bin/do...
~
体験版と銘打っていますが、一部のみ改修しています。
** 最後に… [#jdfa8953]
いかなる場合でもこのスクリプトの商用利用ならびに未改造設...
理由は、トラブルの温床であると共にいつ投稿不可能に陥るか...
* 関連ページ [#e0ced47c]
#related
終了行:
[[WeB DoRaMaシリーズ]]
#contents
#norelated
#br
* WeB DoRaMa Plusスクリプト保管庫 [#rddf62de]
** 本来であればKEEP OUTの代物であるが… [#pc0764dd]
私は資料としてこのスクリプトを公開展示する。~
文句があっても口に出すな…
展示する理由、それは、もう配布されていないのと技術的資料...
** Script [#v60d3a83]
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
#!/usr/local/bin/perl
# WeB DoRaMa version 1.11
# Script written by Shigeto Nakazawa.(1996/11/27)
# This script is free.
# Arranged by Ninjinju-su CGI
require './jcode.pl';
# ---------------------------------
# 各種設定
# ---------------------------------
$max = '150'; # 登録・表示最大数(あまり...
$view = 5; # 初期画面で表示する数
$backurl = '../'; # 帰りのURL(変更してく...
$mojicode = 'sjis'; # Windows なら 'sjis' UNI...
$logfile = 'dorama.log'; # 記録用ファイル
$lockfile = 'dorama.lock'; # 鍵ファイル
$lockcheck = 1; # 鍵ファイルの使用(通常は...
$pluscheck = 1; # 登場人物設定(1:自由登録...
$kyaralogfile = 'kyara.log'; # 登場人物記録用ファイル
$type = '<>'; #ログ形式設定
# ---------------------------------
# フォームからデータをもらう
# ---------------------------------
if ($ENV{'REQUEST_METHOD'} eq "POST") { read(STDIN, $buf...
$typec = $type;
$typec =~ s/\\//;
@pairs = split(/&/,$buffer);
foreach $pair (@pairs) {
($name,$value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex(...
&jcode'convert(*value,$mojicode);
$value =~ s/\n//;
if ($type ne '<>') {
$value =~ s/$typec//;
}
$value =~ s/<(.|\n)*//g;
$FORM{$name} = $value;
}
# ---------------------------------
# HTML出力
# ---------------------------------
print <<"_HTML_header_";
Content-type: text/html\n\n
<!--
WeB DoRaMa は WeB BaNaNa を元に改良したおかぴ@関大さ...
ユニークなので、アイデアをいただき配布することにしまし...
おかぴさん(アイデア): http://www.cmlab.densi.kansai...
じゃわ(著作権) : http://www3.osk.3web.ne.jp/~j...
-->
<HTML>
<HEAD>
<TITLE> WeB DoRaMa Plus </TITLE>
</HEAD>
<BODY BGCOLOR="#FFEFE3" TEXT="#4F4F4F" LINK="#7979FF" VL...
_HTML_header_
# ---------------------------------
# 記録ファイルを読み込む
# ---------------------------------
if ($lockcheck) {
$wt = 0;
while (-f $lockfile) {
$wt++;
if ($wt > 19) {
&error('強制終了されました。処理は中断されま...
}
sleep 1;
}
open (LOCK,">$lockfile");
}
if (!open(IN,$logfile)) {
unlink ($lockfile);
&error("管理者が記録ファイルの読み込みを許可していま...
}
@lines = <IN>;
close(IN);
if (!open(IN,$kyaralogfile)) {
unlink ($lockfile);
&error("管理者が登場人物記録ファイルの読み込みを許可...
}
@tomatos = <IN>;
close(IN);
unlink ($lockfile);
foreach $tomato (@tomatos) {
chop($tomato);
($kyara,$color) = split(/$type/, $tomato);
$kyara = &change1($kyara);
push(@actors,$kyara);
push(@colors,$color);
}
if ($pluscheck) {
$plusok = "<SMALL>[<A HREF=\"doraedit.cgi?plus=0\">...
}
# ---------------------------------
# 分岐
# ---------------------------------
if ($buffer eq '') {
&html;
} else {
®ist;
}
exit;
# *************
# ウェルカム!
# *************
sub html {
print <<"_HTML_top_";
<CENTER>
<H1><I>WeB DoRaMa Plus</I></H1>
<HR>
小説は事実より奇なり。読みたい人は自分も小説を書きましょ...
<BR><BR><BR>
</CENTER><BLOCKQUOTE>
_HTML_top_
for ($i=$view-1;$i>-1;$i--) {
($nn,$date,$dorama,$actor) = split(/$type/, $lin...
$dorama_c = &change1($dorama);
print "<FONT SIZE=+2 COLOR=\"$colors[$actor]\">$...
if (!$i) { $no = $nn; }
}
print <<"_HTML_middle_";
</BLOCKQUOTE><CENTER>
<BR><BR><BR>
<FORM METHOD="post" ACTION="dorama.cgi">
<INPUT TYPE="hidden" NAME="no" VALUE="$no">
_HTML_middle_
print "<SELECT NAME=\"actor\">\n";
print "<OPTION VALUE=\"no\">誰のセリフか選んでね!\n";
for ($i=$#actors;$i>=0;$i--) {
if ($colors[$i] ne 'del') {
print "<OPTION VALUE=\"$i\">$actors[$i]\n";
}
}
print "</SELECT>\n";
print <<"_HTML_buttom_";
<INPUT TYPE=text NAME="dorama" SIZE="50" MAXLENGTH="300"...
<INPUT TYPE=submit VALUE="これでよい(Ok)">
<INPUT TYPE=reset VALUE="消す(Clear)">
</FORM>
</CENTER>
<FONT SIZE=-1 COLOR="#FF0000">
<LI>同じ人物が続けて発言することはできません。
<LI>タグを使用したり、<B>全角150字</B>を超えると登録...
</FONT>
<P>
$plusok
<SMALL>[<A HREF="doraedit.cgi">管理用</A>]</SMALL>
<!-- 著作権表示 (必ず表示してください。) -->
<DIV ALIGN="right"><TT>
WeB DoRaMa v1.11 [<A HREF="http://www3.osk.3web.ne.jp/~j...
WeB DoRaMa Plus v1.0 [<A HREF="http://www.micnet.or.jp/k...
</TT></DIV>
</BODY></HTML>
_HTML_buttom_
}
# *************
# 登録
# *************
sub regist {
$no = $FORM{'no'};
$actor = $FORM{'actor'};
$dorama = $FORM{'dorama'};
$dorama_c = &change0($FORM{'dorama'});
# ---------------------------------
# フォームセキュリチー
# ---------------------------------
($ck_no,$date,$ck_dorama,$ck_actor) = split(/$type/, $li...
if ($ck_no ne $no) {
&error("残念、タイムオーバーです。すでに、誰かが執筆...
}
if ($ck_actor == $actor) {
&error("同じ人がセリフを言ってはいけません。");
}
if ($colors[$actor] eq 'no') {
&error("セリフを言う人を選んでください。");
}
if ($colors[$actor] eq 'del') {
&error("削除されていますので使えません");
}
if ($dorama eq '') {
&error("何も書かれていないか、または使用禁止の文字が...
}
if (length($dorama) >= 300) {
&error("言葉が長すぎます。文字数は全角150字を超え...
}
# ----------------------------------
# 日付を取得する
# ----------------------------------
($sec,$min,$hour,$day,$mon) = localtime(time);
$mon++;
if ($sec < 10) { $sec = "0$sec"; }
if ($min < 10) { $min = "0$min"; }
if ($hour < 10) { $hour = "0$hour"; }
if ($day < 10) { $day = "0$day"; }
if ($mon < 10) { $mon = "0$mon"; }
$date = "$mon/$day $hour:$min:$sec";
# ---------------------------------
# HTML出力
# ---------------------------------
print <<"_HTML_thanks_";
<CENTER><H1><I>WeB DoRaMa Plus</I></H1>
<IMG SRC="dorama.gif"></CENTER><P>
執筆ありがとう!(^o^)<BR>
ゆっくりご覧下さい。見終わったら、<A HREF="$backurl">こ...
<CENTER><IMG SRC="dorama.gif"></CENTER>
<P>
<SMALL>[<A HREF="dorama.cgi?">もどる</A>]</SMALL><br>
_HTML_thanks_
$i = 0;
$no = ($no + 1) % 9999;
@new = '';
unshift(@lines,"$no$typec$date$typec$dorama_c$typec$acto...
foreach $line (@lines) {
$i++;
push(@new,$line);
if ($i == $max) { last; }
}
for ($i=@new-1;$i>0;$i--) {
($no,$date,$dorama,$actor) = split(/$type/,$new[$i]);
$dorama_c = &change1($dorama);
print "<SMALL><FONT COLOR=\"green\">$date</FONT></SM...
}
# ---------------------------------
# 記録ファイルに登録する
# ---------------------------------
if ($lockcheck) {
$wt = 0;
while (-f $lockfile) {
$wt++;
if ($wt > 19) {
&error('強制終了されました。処理は中断されま...
}
sleep 1;
}
open (LOCK,">$lockfile");
}
if (!open(OUT,">$logfile")) {
unlink ($lockfile);
&error("管理者が記録用ファイルの書き込みを許可してい...
}
print OUT @new;
close(OUT);
unlink ($lockfile);
}
# ***************************
# 禁止文字コードの変換処理
# ***************************
sub change0 {
local($text) = $_[0];
$text =~ s/\(/(/g;
$text =~ s/\)/)/g;
$text =~ s/\*/*/g;
$text =~ s/\+/+/g;
$text =~ s/\././g;
$text =~ s/\?/?/g;
$text =~ s/\[/[/g;
$text =~ s/\\/\/g;
$text =~ s/\]/]/g;
$text =~ s/\{/{/g;
$text =~ s/\|/|/g;
$text =~ s/\}/}/g;
return $text;
}
sub change1 {
local($text) = $_[0];
$text =~ s/(/\(/g;
$text =~ s/)/\)/g;
$text =~ s/*/\*/g;
$text =~ s/+/\+/g;
$text =~ s/./\./g;
$text =~ s/?/\?/g;
$text =~ s/[/\[/g;
$text =~ s/\/\\/g;
$text =~ s/]/\]/g;
$text =~ s/{/\{/g;
$text =~ s/|/\|/g;
$text =~ s/}/\}/g;
return $text;
}
# ***************************
# エラー処理
# ***************************
sub error {
print <<"_HTML_error_";
<H2>監督<FONT COLOR="red">『カット!!』</FONT></H2>
$_[0]
</BODY></HTML>
_HTML_error_
exit;
}
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
#!/usr/local/bin/perl
# WeB dorama Editor version 1.11
#
# Script written by Shigeto Nakazawa.(1996/11/27)
# This script is free.
# Arranged by Ninjinju-su CGI
require './jcode.pl';
# ---------------------------------
# 各種設定
# ---------------------------------
$pass = 'password'; # 必ず半角英数8文字以内で...
$mojicode = 'sjis'; # Windows なら 'sjis' UNI...
$logfile = 'dorama.log'; # 記録用ファイル
$lockfile = 'dorama.lock'; # 鍵ファイル
$lockcheck = 1; # 鍵ファイルの使用(通常は...
$pluscheck = 1; # 登場人物設定(1:自由登録...
$kyaralogfile = 'kyara.log'; # 登場人物記録用ファイル
@plus_colors = ('#000000=くろ',
'#FF0000=あか',
'#008000=みどり',
'#0000FF=あお',
'#00FFFF=みずいろ',
'#FF8000=みかん',
'#804000=ちゃ',
'#00C0C0=まりんぶるー',
'#FF8080=もも',
'#808080=ねずみ'); # 登場人物につける色
$type = '<>'; #ログ形式設定
# ---------------------------------
# フォームからデータをもらう
# ---------------------------------
if ($ENV{'REQUEST_METHOD'} eq "POST") { read(STDIN, $buf...
$typec = $type;
$typec =~ s/\\//;
@pairs = split(/&/,$buffer);
foreach $pair (@pairs)
{
($name,$value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex(...
&jcode'convert(*value,$mojicode);
$value =~ s/\n//;
if ($type ne '<>') {
$value =~ s/$typec//;
}
if ($value ne 'on') {
$FORM{$name} = $value;
} else {
$FORM{$name} = 1;
}
}
$rq_dorama = &change0($FORM{'dorama'});
$rq_actor = &change0($FORM{'actor'});
$pw = $FORM{'pass'};
$typec = $type;
$typec =~ s/\\//;
# ---------------------------------
# HTML出力
# ---------------------------------
print <<"_HTML_header_";
Content-type: text/html\n\n
<HTML><HEAD><TITLE> WeB DoRaMa Editor Plus </TITLE></HEAD>
<BODY BGCOLOR="#FFEFE3" text="#4F4F4F" link="#7979FF" vl...
_HTML_header_
# ---------------------------------
# 記録ファイルを読み込む
# ---------------------------------
if ($lockcheck) {
local($wt) = 0;
while (-f $lockfile) {
if (++$wt > 5) {
&error('強制終了されました。処理は中断されま...
}
sleep 4;
}
open (LOCK,">$lockfile");
}
if (!open(IN,$logfile)) {
unlink ($lockfile);
&error("記録ファイルの読み込みに失敗しました。");
}
@lines = <IN>;
close(IN);
if (!open(IN,$kyaralogfile)) {
unlink ($lockfile);
&error("登場人物記録ファイルの読み込みに失敗しました...
}
@tomatos = <IN>;
close(IN);
unlink ($lockfile);
@ptomatos = @tomatos;
foreach $tomato (@tomatos) {
chop($tomato);
($kyara,$color) = split(/$type/, $tomato);
$kyara = &change1($kyara);
push(@actors,$kyara);
push(@colors,$color);
}
if ($pw eq $pass) {
$back = "doraedit.cgi?pass=$pw";
} else {
$back = "dorama.cgi";
}
# ---------------------------------
# plusのみ分岐
# ---------------------------------
if ($FORM{'plus'} eq '0' && $pluscheck || $pass eq $pw &...
+
} elsif ($FORM{'plus'} eq '1' && $pluscheck || $pass eq ...
&pluss;
} elsif ($pass eq $pw && $FORM{'plus'} eq '2') {
&plusedit;
} elsif ($pass eq $pw && $FORM{'plus'} eq '3') {
&plusregist;
}
# ---------------------------------
# パスワードのチェック
# ---------------------------------
if ($pass ne $pw) {
print <<"_HTML_password_";
<HR>
<CENTER>
パスワード
<FORM ACTION="doraedit.cgi" METHOD="post">
<INPUT TYPE="password" NAME="pass" SIZE=10>
<INPUT TYPE="submit" VALUE="おっけー">
</FORM>
</CENTER>
<HR>
_HTML_password_
exit;
}
# ---------------------------------
# 編集処理
# ---------------------------------
($new_no) = split(/$type/,$lines[0]);
$new_no = ($new_no + 1) % 9999;
foreach $line (@lines) {
($no,$date) = split(/$type/,$line);
if ($FORM{$no} == 1) {
$check = 1;
if ($rq_dorama ne '') {
$line = "$no$typec$date$typec$rq_dorama$type...
push (@new,$line);
}
} else {
push (@new,$line);
}
}
# ---------------------------------
# 記録ファイルに書き込む
# ---------------------------------
if ($check) {
($no,$date,$dorama,$actor) = split(/$type/,$new[0]);
$new[0] = "$new_no$typec$date$typec$dorama$typec$act...
if ($lockcheck) {
local($wt) = 0;
while (-f $lockfile) {
if (++$wt > 5) {
&error('強制終了されました。処理は中断さ...
}
sleep 4;
}
open (LOCK,">$lockfile");
}
if (!open(OUT,">$logfile")) {
unlink ($lockfile);
&error("記録ファイルの書き込みに失敗しました。");
}
print OUT @new;
close(OUT);
unlink ($lockfile);
}
# ---------------------------------
# リストを表示
# ---------------------------------
print <<"_EOF_";
<CENTER>
<H2><I>WeB dorama Editor Plus</I></H2>
</CENTER>
<P>
<FONT COLOR="#FF0000">★使い方★</FONT>
<BR>
<FONT SIZE=-1><OL>
<LI>編集する項目をチェックします
<LI>編集内容を書きます(このとき、何も書かなかった場合、...
<LI>[編集開始]で書き換えられます。
</OL></FONT>
<P>
<CENTER>
<FORM ACTION="doraedit.cgi" method="post">
<INPUT TYPE="hidden" NAME="pass" VALUE="$pw">
_EOF_
print "<SELECT NAME=\"actor\">\n";
print "<OPTION VALUE=\"no\">誰のセリフか選んでね!\n";
for ($i=$#actors;$i>=0;$i--) {
if ($colors[$i] ne 'del') {
print "<OPTION VALUE=\"$i\">$actors[$i]\n";
}
}
print "</SELECT>\n";
print <<"_EOF_";
<INPUT TYPE="text "NAME="dorama" SIZE="50">
<INPUT TYPE="submit" VALUE="編集開始"><BR>
</CENTER>
<SMALL>[<FONT COLOR="#0000FF">登場人物<A HREF="doraedit....
<SMALL>[<A HREF="dorama.cgi">ドラマ</A>]</SMALL>
<HR>
_EOF_
foreach $line (@new) {
($no,$date,$dorama,$actor) = split(/$type/,$line);
$dorama = &change1($dorama);
print "<INPUT TYPE=\"checkbox\" NAME=\"$no\">\n";
print "<FONT SIZE=-1 COLOR=#FF0000>$date</FONT> : ";
print "<FONT SIZE=+1 COLOR=#CC0000>$actors[$actor]</...
print "『<FONT SIZE=+1 COLOR=#0000CC>$dorama</FONT>...
}
# ***************************
# 登場人物編集
# ***************************
# ---------------------------------
# 登場人物追加フォーム
# ---------------------------------
sub plus {
print <<"_EOF_";
<CENTER>
<H1><I>WeB DoRaMa Plus</I></H1>
<HR>
あなたも小説に登場人物を追加したいはず!ということで・・・
<BR><BR><BR>
<FORM METHOD="post" ACTION="doraedit.cgi">
<INPUT TYPE="hidden" NAME="plus" VALUE="1">
<INPUT TYPE="hidden" NAME="pass" VALUE="$pw">
_EOF_
print "色:<SELECT NAME=\"color\">\n";
foreach $plus_color (@plus_colors) {
($code,$color_name) = split(/=/, $plus_color);
print "<OPTION VALUE=\"$code\">$color_name\n";
}
print "</SELECT> \n";
print <<"_HTML_";
人物名:<INPUT TYPE=text NAME="name" SIZE="50" MAXLENGTH...
<INPUT TYPE=submit VALUE="これでよい(Ok)">
<INPUT TYPE=reset VALUE="消す(Clear)">
</FORM>
</CENTER>
<FONT SIZE=-1 COLOR="#FF0000">
<LI>変な登場人物名は入れないでください
<LI>タグを使用したり、<B>全角20字</B>を超えると登録さ...
</FONT>
<P>
<SMALL>[<A HREF="$back">もどる</A>]</SMALL>
_HTML_
exit;
}
# ---------------------------------
# 登場人物名登録
# ---------------------------------
sub pluss {
$color = $FORM{'color'};
$name = $FORM{'name'};
$name_c = &change0($name);
if ($name eq '') {
&error("何も書かれていないか、または使用禁止の文字が...
}
if (length($name) >= 40) {
&error("名前が長すぎます。文字数は全角20字を超えて...
}
# ---------------------------------
# 登場人物専用記録ファイルに登録する
# ---------------------------------
if ($lockcheck) {
$wt = 0;
while (-f $lockfile) {
$wt++;
if ($wt > 19) {
&error('強制終了されました。処理は中断されま...
}
sleep 1;
}
open (LOCK,">$lockfile");
}
if (!open(OUT,">>$kyaralogfile")) {
unlink ($lockfile);
&error("管理者が登場人物記録用ファイルの書き込みを許...
}
print OUT "$name_c$typec$color\n";
close(OUT);
unlink ($lockfile);
print <<"_EOF_";
<CENTER>
<H1><I>WeB DoRaMa<br>Plus</I></H1>
<HR>
あなたが登場させたい人物の名前が追加されました
<BR><BR><BR>
<H2><FONT COLOR="$color"><B>『$name』</B></FONT>が追加さ...
</CENTER>
<P>
<SMALL>[<A HREF="$back">もどる</A>]</SMALL>
_EOF_
exit;
}
# ---------------------------------
# 登場人物編集フォーム
# ---------------------------------
sub plusedit {
print <<"_EOF_";
<CENTER>
<H1><I>WeB DoRaMa Plus Editor</I></H1>
</CENTER>
<HR>
<P>
<FONT COLOR="#FF0000">★使い方★</FONT>
<BR>
<FONT SIZE=-1><OL>
<LI>編集したいを登場人物名を選びます
<LI>登場人物の色や名前を書き換えたりします
<DD>(このとき、色の中の削除を選んだ場合、削除されます)
<DD>(削除したものも編集可能です)
<LI>[編集開始]で書き換えられます。
</OL></FONT>
<P>
<CENTER>
<FORM METHOD="post" ACTION="doraedit.cgi">
<INPUT TYPE="hidden" NAME="plus" VALUE="3">
<INPUT TYPE="hidden" NAME="pass" VALUE="$pw">
_EOF_
print "編集人物:<SELECT NAME=\"actor_p\">\n";
for ($i=0;$i<@actors;$i++) {
print "<OPTION VALUE=\"$i\">$actors[$i]\n";
}
print "</SELECT>\n";
print "色:<SELECT NAME=\"color_p\">\n";
foreach $plus_color (@plus_colors) {
($code,$color_name) = split(/=/, $plus_color);
print "<OPTION VALUE=\"$code\">$color_name\n";
}
print "<OPTION VALUE=\"del\">削除\n";
print "</SELECT> \n";
print <<"_HTML_";
人物名:<INPUT TYPE=text NAME="name" SIZE="50" MAXLENGTH...
<INPUT TYPE=submit VALUE="編集開始">
<INPUT TYPE=reset VALUE="編集取消">
</FORM>
</CENTER>
<FONT SIZE=-1 COLOR="#FF0000">
<LI>タグを使用したり、<B>全角20字</B>を超えると登録さ...
</FONT>
<P>
<SMALL>[<A HREF="doraedit.cgi?pass=$pw">もどる</A>]</SMA...
_HTML_
exit;
}
sub plusregist {
$color = $FORM{'color_p'};
$actor = $FORM{'actor_p'};
$name = $FORM{'name'};
$name_c = &change0($name);
if ($color eq 'del') {
$name = $mes = "削除";
} else {
$mes = "<FONT COLOR=\"$color\"><B>『$name』</B></FON...
}
if ($actor eq '' || $color eq '') {
&error("編集人物名または色が選ばれていません");
}
if ($name eq '' && $color ne 'no') {
&error("何も書かれていないか、または使用禁止の文字が...
}
if (length($name) >= 40) {
&error("名前が長すぎます。文字数は全角20字を超えて...
}
$sio = 0;
foreach $line (@ptomatos) {
if ($sio eq $actor) {
$line = "$name_c$typec$color\n";
push (@ptomato,$line);
} else {
push (@ptomato,$line);
}
$sio++;
}
# ---------------------------------
# 登場人物記録ファイルに登録する
# ---------------------------------
if ($lockcheck) {
$wt = 0;
while (-f $lockfile) {
$wt++;
if ($wt > 19) {
&error('強制終了されました。処理は中断されま...
}
sleep 1;
}
open (LOCK,">$lockfile");
}
if (!open(OUT,">$kyaralogfile")) {
unlink ($lockfile);
&error("登場人物記録ファイルの書き込みに失敗しました...
}
print OUT @ptomato;
close(OUT);
unlink ($lockfile);
print <<"_EOF_";
<CENTER>
<H1><I>WeB DoRaMa<br>Plus Editor</I></H1>
<HR>
みごと編集が完了されましたわよ。
<BR><BR><BR>
<H2><FONT COLOR="$colors[$actor]"><B>『$actors[$actor]』...
</CENTER>
<P>
<SMALL>[<A HREF="doraedit.cgi?pass=$pw">もどる</A>]</SMA...
_EOF_
exit;
}
# ***************************
# 禁止文字コードの変換処理
# ***************************
sub change0 {
local($text) = $_[0];
$text =~ s/\(/(/g;
$text =~ s/\)/)/g;
$text =~ s/\*/*/g;
$text =~ s/\+/+/g;
$text =~ s/\././g;
$text =~ s/\?/?/g;
$text =~ s/\[/[/g;
$text =~ s/\\/\/g;
$text =~ s/\]/]/g;
$text =~ s/\{/{/g;
$text =~ s/\|/|/g;
$text =~ s/\}/}/g;
return $text;
}
sub change1 {
local($text) = $_[0];
$text =~ s/(/\(/g;
$text =~ s/)/\)/g;
$text =~ s/*/\*/g;
$text =~ s/+/\+/g;
$text =~ s/./\./g;
$text =~ s/?/\?/g;
$text =~ s/[/\[/g;
$text =~ s/\/\\/g;
$text =~ s/]/\]/g;
$text =~ s/{/\{/g;
$text =~ s/|/\|/g;
$text =~ s/}/\}/g;
return $text;
}
# ***************************
# エラー処理
# ***************************
sub error {
print <<"_HTML_error_";
<H2>エラーが発生しました。</H2>
$_[0]
</BODY></HTML>
_HTML_error_
exit;
}
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
A夫<>#0000FF
B子<>#FF0000
C助<>#008800
D美<>#FF0000
ナレーション<>#000000
効果音<>#008000
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
package jcode;
;#######################################################...
;#
;# jcode.pl: Perl library for Japanese character code co...
;#
;# Copyright (c) 1995,1996 Kazumasa Utashiro <utashiro@i...
;# Internet Initiative Japan Inc.
;# 1-4 Sanban-cho, Chiyoda-ku, Tokyo 102, Japan
;#
;# Copyright (c) 1992,1993,1994 Kazumasa Utashiro
;# Software Research Associates, Inc.
;# Original by srekcah@sra.co.jp, Feb 1992
;#
;# Redistribution for any purpose, without significant m...
;# is granted as long as all copyright notices are retai...
;# SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY ...
;# IMPLIED WARRANTIES ARE DISCLAIMED.
;#
;; $rcsid = q$Id: jcode.pl,v 2.0 1996/10/02 16:02:38 uta...
;#
;#######################################################...
;#
;# 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.
;#
;# Code detection between euc and sjis is very difficult
;# or sometimes impossible or even lead to wrong result
;# when it's include JIS X0201 KANA characters. So JIS
;# X0201 KANA is ignored for automatic code detection.
;#
;# &jcode'convert(*line, $ocode [, $icode [, $option]])
;# Convert the line in any Japanese code to the specified
;# code 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.
;# See above). $icode also can be specified, but xxx2yyy
;# routine is more efficient when both codes are known.
;#
;# It returns a list of pointer of convert subroutine and
;# input code. It means that this routine returns the
;# input code of the line in scalar context.
;#
;# 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().
;#
;# &to($ocode, $line [, $icode [, $option]])
;# &jis($line [, $icode [, $option]])
;# &euc($line [, $icode [, $option]])
;# &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 added as a prefix
;# 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. This
;# funciton is under construction and doesn't have full
;# feature of tr. Range operator like a-z is partially
;# supported: JIS or EUC and first byte should be same on
;# first and last character (so HIRAGANA-KATAKANA
;# conversion is possible). Only 'd' is interpreted as
;# option.
;#
;# &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 other functions. You
;# don't have to call this when using jocde.pl by do or
;# require. Call it first if you embedded the jcode.pl
;# in your script.
;#
;#######################################################...
;#
;# SAMPLES
;#
;# Convert any Kanji code to JIS and print each line wit...
;#
;# while (<>) {
;# $code = &jcode'convert(*_, 'jis');
;# print $code, "\t", $_;
;# }
;#
;# Convert all lines to JIS according to the first recog...
;#
;# 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(@readahead, $_);
;# next unless $code;
;# eval "&jcode'${code}2jis(*_), print while (\$_ = ...
;# eval "&jcode'${code}2jis(*_), print while (\$_ = ...
;# last;
;# }
;#
;#######################################################...
;#
;# Call initialize function if it is not called yet. Th...
;# strange but it makes easy to embed the jcode.pl at th...
;# script. Call &jcode'init at the beginning of the scr...
;# case.
;#
&init unless defined $version;
;#
;# Initialize variables.
;#
sub init {
$version = $rcsid =~ /,v ([\d.]+)/ ? $1 : 'unkown';
$re_bin = '[\000-\006\177\377]';
$re_jp = '\e\$[\@B]';
$re_asc = '\e\([BJ]';
$re_kana = '\e\(I';
($esc_jp, $esc_asc, $esc_kana) = ("\e\$B", "\e(B", "...
$re_sjis_c = '[\201-\237\340-\374][\100-\176\200-\37...
$re_sjis_kana = '[\241-\337]';
$re_euc_c = '[\241-\376][\241-\376]';
$re_euc_kana = '\216[\241-\337]';
# These variables are retained only for backward com...
$re_euc_s = "($re_euc_c)+";
$re_sjis_s = "($re_sjis_c)+";
$cache = 1;
# X0201 -> X0208 KANA conversion table. Looks weird...
# much. This is simply JIS text without escape sequ...
($h2z_high = $h2z = <<'__TABLE_END__') =~ tr/\021-\1...
! !# $ !" % !& " !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;
$_ = '';
for $f ('jis', 'sjis', 'euc') {
for $t ('jis', 'sjis', 'euc') {
$_ .= "\$convf{'$f', '$t'} = *${f}2${t};\n";
}
$_ .= "\$h2zf{'$f'} = *h2z_${f};\n\$z2hf{'$f'} = *z2h_$...
}
eval $_;
}
;#
;# Set escape sequences which should be put before and a...
;# (JIS X0208) string.
;#
sub jis_inout {
$esc_jp = shift || $esc_jp;
$esc_jp = "\e\$$esc_jp" if length($esc_jp) == 1;
$esc_asc = shift || $esc_asc;
$esc_asc = "\e\($esc_asc" if length($esc_asc) == 1;
($esc_jp, $esc_asc);
}
;#
;# Get JIS in and out sequences from the string.
;#
sub get_inout {
local($esc_jp, $esc_asc);
$_[$[] =~ /$re_jp/o && ($esc_jp = $&);
$_[$[] =~ /$re_asc/o && ($esc_asc = $&);
($esc_jp, $esc_asc);
}
;#
;# Recognize character code.
;#
sub getcode {
local(*_) = @_;
return undef unless /[\e\200-\377]/;
return 'jis' if /$re_jp|$re_asc|$re_kana/o;
return 'binary' if /$re_bin/o;
local($sjis, $euc);
$sjis += length($&) while /($re_sjis_c)+/go;
$euc += length($&) while /($re_euc_c)+/go;
(&max($sjis, $euc), ('euc', undef, 'sjis')[($sjis<=>...
}
sub max { $_[ $[ + ($_[$[] < $_[$[+1]) ]; }
;#
;# Convert any code to specified code.
;#
sub convert {
local(*_, $ocode, $icode, $opt) = @_;
return (undef, undef) unless $icode = $icode || &get...
return (undef, $icode) if $icode eq 'binary';
$ocode = 'jis' unless $ocode;
$ocode = $icode if $ocode eq 'noconv';
local(*convf) = $convf{$icode, $ocode};
do convf(*_, $opt);
(*convf, $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;
if (s/($re_sjis_kana)+|($re_sjis_c)+/&_sjis2jis($&)/...
s/$re_asc($re_jp|$re_kana)/$1/go;
}
$n;
}
sub _sjis2jis {
local($_) = @_;
if (/^$re_sjis_kana/o) {
$n += tr/\241-\337/\041-\137/;
$esc_kana . $_ . $esc_asc;
} else {
$n += s/$re_sjis_c/$s2e{$&}||&s2e($&)/geo;
tr/\241-\376/\041-\176/;
$esc_jp . $_ . $esc_asc;
}
}
;#
;# EUC to JIS
;#
sub euc2jis {
local(*_, $opt, $n) = @_;
&euc2euc(*_, $opt) if $opt;
if (s/($re_euc_kana)+|($re_euc_c)+/&_euc2jis($&)/geo...
s/$re_asc($re_jp|$re_kana)/$1/go;
}
$n;
}
sub _euc2jis {
local($_) = @_;
local($esc) = tr/\216//d ? $esc_kana : $esc_jp;
$n += tr/\241-\376/\041-\176/;
$esc . $_ . $esc_asc;
}
;#
;# JIS to EUC
;#
sub jis2euc {
local(*_, $opt, $n) = @_;
s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2euc($1,$2)...
&euc2euc(*_, $opt) if $opt;
$n;
}
sub _jis2euc {
local($esc, $_) = @_;
if ($esc !~ /$re_asc/o) {
$n += tr/\041-\176/\241-\376/;
s/[\241-\337]/\216$&/g if $esc =~ /$re_kana/o;
}
$_;
}
;#
;# JIS to SJIS
;#
sub jis2sjis {
local(*_, $opt, $n) = @_;
&jis2jis(*_, $opt) if $opt;
s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2sjis($1,$2...
$n;
}
sub _jis2sjis {
local($esc, $_) = @_;
if ($esc !~ /$re_asc/o) {
$n += tr/\041-\176/\241-\376/;
s/$re_euc_c/$e2s{$&}||&e2s($&)/geo if $esc =~ /$re_jp/o;
}
$_;
}
;#
;# SJIS to EUC
;#
sub sjis2euc {
local(*_, $opt,$n) = @_;
$n = s/$re_sjis_kana|$re_sjis_c/$s2e{$&}||&s2e($&)/g...
&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/$e2s{$&}||&e2s($&)/geo;
}
sub e2s {
local($c1, $c2, $code);
($c1, $c2) = unpack('CC', $code = shift);
if ($c1 == 0x8e) {
return substr($code, 1, 1);
} 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_jp/$esc_jp/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_jp . &_h2z_jis($1)/geo) {
1 while s/($re_jp[^\e]*)$re_jp/$1/o;
}
$n;
}
sub _h2z_jis {
local($_) = @_;
$n += s/[\41-\137]([\136\137])?/$h2z{$&}/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_jp([^\e]+)/&_z2h_jis($1)/geo;
$n;
}
sub _z2h_jis {
local($_) = @_;
s/(\%[!-~]|![\#\"&VW+,<])+|([^!%][!-~]|![^\#\"&VW+,<...
$_;
}
sub __z2h_jis {
local($_) = @_;
return $esc_jp . $_ unless /^%/ || /^![\#\"&VW+,<]/;
$n += length($_) / 2;
s/../$z2h{$&}/g;
$esc_kana . $_;
}
sub z2h_euc {
local(*_, $n) = @_;
&init_z2h_euc unless defined %z2h_euc;
s/$re_euc_c|$re_euc_kana/$z2h_euc{$&} ? ($n++, $z2h_...
$n;
}
sub z2h_sjis {
local(*_, $n) = @_;
&init_z2h_sjis unless defined %z2h_sjis;
s/$re_sjis_c/$z2h_sjis{$&} ? ($n++, $z2h_sjis{$&}) :...
$n;
}
;#
;# Initializing JIS X0208 to X0201 KANA table for EUC an...
;# can be done in &init but it's not worth doing. Simil...
;# precalculated table is not worth to occupy the file s...
;# reduce the readability. The author personnaly discou...
;# X0201 Kana character in the any situation.
;#
sub init_z2h_euc {
local($k, $_);
s/[\241-\337]/\216$&/g && ($z2h_euc{$k} = $_) while ...
}
sub init_z2h_sjis {
local($_, $v);
/[\200-\377]/ && ($z2h_sjis{&e2s($_)} = $v) while ($...
}
;#
;# TR function for 2-byte code
;#
sub tr {
local(*_, $from, $to, $opt) = @_;
local(@from, @to, %table);
local($jis, $n) = (0, 0);
local($ascii) = '(\\\\[\\-\\\\]|[\0-\133\135-\177])';
&jis2euc(*_), $jis++ if $_ =~ /$re_jp/o;
&jis2euc(*to), $jis++ if $to =~ /$re_jp/o;
&jis2euc(*from) if $from =~ /$re_jp/o;
grep(s/([\200-\377])[\200-\377]-\1[\200-\377]/&_expn...
grep(s/$ascii-$ascii/&_expnd1($&)/geo, $from, $to);
@to = $to =~ /[\200-\377][\000-\377]|[\000-\377]...
@from = $from =~ /[\200-\377][\000-\377]|[\000-\377]...
push(@to, ($opt =~ /d/ ? '' : $to[$#to]) x (@from - ...
@table{@from} = @to;
s/[\200-\377][\000-\377]|[\000-\377]/
defined($table{$&}) && ++$n ? $table{$&} : $&/ge;
&euc2jis(*_) if $jis;
$n;
}
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;
*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/i...
&ref(http://webdoramamuseum.s1003.xrea.com/common/img/cgi...
** File [#q41e61ea]
とりあえず代理で配布する。~
Perlをかじった上で触れたことがある者なら何が不足している...
登場人物にHTMLタグが登録されると言う脆弱性により書き込め...
~
CENTER:それでもよければダウンロードしてもいい…
- [[&ref(http://webdoramamuseum.s1003.xrea.com/common/img...
[[&ref(http://webdoramamuseum.s1003.xrea.com/common/img/d...
CENTER:もし設置する場合は…
dorama.cgi [755|705|700]~
doraedit.cgi [755|705|700]~
kyara.log [666|606|600]~
dorama.log [666|606|600]~
jcode.pl [644|606|600]~
dorama.gif [644]~
** 体験版 [#v915f6f8]
[[体験版>http://webdoramamuseum.s1003.xrea.com/cgi-bin/do...
~
体験版と銘打っていますが、一部のみ改修しています。
** 最後に… [#jdfa8953]
いかなる場合でもこのスクリプトの商用利用ならびに未改造設...
理由は、トラブルの温床であると共にいつ投稿不可能に陥るか...
* 関連ページ [#e0ced47c]
#related
ページ名:
警告:くれぐれもまとめサイトに転載・記載するのだけはおやめください。