count


#author("2017-11-05T18:51:01+09:00","","")
#author("2020-12-17T23:19:49+09:00","","")
[[WeB DoRaMaシリーズ]]

#contents
#norelated
#br

* WeB DoRaMa Plusスクリプト保管庫 [#rddf62de]

** 本来であればKEEP OUTの代物であるが… [#pc0764dd]

私は資料としてこのスクリプトを公開展示する。~
文句があっても口に出すな…

展示する理由、それは、もう配布されていないのと技術的資料でもあるからだ…

** Script [#v60d3a83]

*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/img/download/dl_icon.gif,left,nolink,18x18,dorama.cgi);dorama.cgi:http://webdoramamuseum.s1003.xrea.com/common/cgi-bin/link/perldnload.cgi?dlfile=http://webdoramamuseum.s1003.xrea.com/common/file/dorama-plus/dorama_cgi.txt&dlname=dorama_cgi.txt]] [#m6784c2f]

 #!/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'  UNIX なら 'euc' を推奨。
 
 $logfile  = 'dorama.log';     # 記録用ファイル
 $lockfile = 'dorama.lock';    # 鍵ファイル
 $lockcheck = 1;               # 鍵ファイルの使用(通常は 1 にしてください)
 
 $pluscheck = 1;               # 登場人物設定(1:自由登録モード 0:管理者限定登録モード)
 $kyaralogfile  = 'kyara.log'; # 登場人物記録用ファイル
 
 $type = '<>';                 #ログ形式設定
 
 # ---------------------------------
 # フォームからデータをもらう
 # ---------------------------------
 
 if ($ENV{'REQUEST_METHOD'} eq "POST") { read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'}); } else { $buffer = $ENV{'QUERY_STRING'}; }
 
 $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($1))/eg;
     &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-u.ac.jp/~okamura/
   じゃわ(著作権)      : http://www3.osk.3web.ne.jp/~jawa/
 -->
 <HTML>
 <HEAD>
 <TITLE> WeB DoRaMa Plus </TITLE>
 </HEAD>
 <BODY BGCOLOR="#FFEFE3" TEXT="#4F4F4F" LINK="#7979FF" VLINK="#7979FF" ALINK="#0000FF">
 _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\">登場人物追加</A>]</SMALL>";
 }
 
 # ---------------------------------
 # 分岐
 # ---------------------------------
 
 if ($buffer eq '') {
     &html;
 } else {
     &regist;
 }
 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/, $lines[$i]);
         $dorama_c = &change1($dorama);
         print "<FONT SIZE=+2 COLOR=\"$colors[$actor]\">$actors[$actor]『$dorama_c』</FONT><BR>\n";
         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"><BR>
 
 <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/~jawa/">Shigeto Nakazawa</A>]<BR>
 WeB DoRaMa Plus v1.0 [<A HREF="http://www.micnet.or.jp/k-iwata/cgi/">Ninjinju-su CGI</A>]
 </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/, $lines[0]);
 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("何も書かれていないか、または使用禁止の文字が使われているようです。&lt;は使用しないでください。");
 }
 
 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">ここをクリックする</A>ことで前のページに戻ります。<P>
 <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$actor\n");
 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></SMALL> : <FONT SIZE=+1 COLOR=\"$colors[$actor]\">$actors[$actor]『$dorama_c』</FONT><HR>\n";
 }
 
 # ---------------------------------
 # 記録ファイルに登録する
 # ---------------------------------
 
 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/\(/&#40;/g;
     $text =~ s/\)/&#41;/g;
     $text =~ s/\*/&#42;/g;
     $text =~ s/\+/&#43;/g;
     $text =~ s/\./&#46;/g;
     $text =~ s/\?/&#63;/g;
     $text =~ s/\[/&#91;/g;
     $text =~ s/\\/&#92;/g;
     $text =~ s/\]/&#93;/g;
     $text =~ s/\{/&#123;/g;
     $text =~ s/\|/&#124;/g;
     $text =~ s/\}/&#125;/g;
     return $text;
 }
 
 sub change1 {
     local($text) = $_[0];
     $text =~ s/&#40;/\(/g;
     $text =~ s/&#41;/\)/g;
     $text =~ s/&#42;/\*/g;
     $text =~ s/&#43;/\+/g;
     $text =~ s/&#46;/\./g;
     $text =~ s/&#63;/\?/g;
     $text =~ s/&#91;/\[/g;
     $text =~ s/&#92;/\\/g;
     $text =~ s/&#93;/\]/g;
     $text =~ s/&#123;/\{/g;
     $text =~ s/&#124;/\|/g;
     $text =~ s/&#125;/\}/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/img/download/dl_icon.gif,left,nolink,18x18,doraedit.cgi);doraedit.cgi:http://webdoramamuseum.s1003.xrea.com/common/cgi-bin/link/perldnload.cgi?dlfile=http://webdoramamuseum.s1003.xrea.com/common/file/dorama-plus/doraedit_cgi.txt&dlname=doraedit_cgi.txt]] [#ba081a78]

 #!/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'  UNIX なら 'euc' を推奨。
 
 $logfile  = 'dorama.log';     # 記録用ファイル
 $lockfile = 'dorama.lock';    # 鍵ファイル
 $lockcheck = 1;               # 鍵ファイルの使用(通常は 1 にしてください)
 
 $pluscheck = 1;               # 登場人物設定(1:自由登録モード 0:管理者限定登録モード)
 $kyaralogfile  = 'kyara.log'; # 登場人物記録用ファイル
 @plus_colors = ('#000000=くろ',
 		'#FF0000=あか',
 		'#008000=みどり',
 		'#0000FF=あお',
 		'#00FFFF=みずいろ',
 		'#FF8000=みかん',
 		'#804000=ちゃ',
 		'#00C0C0=まりんぶるー',
 		'#FF8080=もも',
 		'#808080=ねずみ'); # 登場人物につける色
 
 $type = '<>';                 #ログ形式設定
 
 # ---------------------------------
 # フォームからデータをもらう
 # ---------------------------------
 
 if ($ENV{'REQUEST_METHOD'} eq "POST") { read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'}); } else { $buffer = $ENV{'QUERY_STRING'}; }
 
 $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($1))/eg;
     &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" vlink="#7979FF" alink="#0000FF">
 _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 && $FORM{'plus'} eq '0') {
     &plus;
 } elsif ($FORM{'plus'} eq '1' && $pluscheck || $pass eq $pw && $FORM{'plus'} eq '1') {
     &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$typec$rq_actor\n";
             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$actor";
     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.cgi?pass=$pw&plus=0">追加</A>&<A HREF="doraedit.cgi?pass=$pw&plus=2">編集</A></FONT>]</SMALL>
 <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]</FONT> ";
     print "『<FONT SIZE=+1 COLOR=#0000CC>$dorama</FONT>』<HR>\n";
 }
 
 # ***************************
 # 登場人物編集
 # ***************************
 
 # ---------------------------------
 # 登場人物追加フォーム
 # ---------------------------------
 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="20"><BR>
 
 <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("何も書かれていないか、または使用禁止の文字が使われているようです。&lt;は使用しないでください。");
 }
 
 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>が追加されました</H2>
 
 </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="20"><BR>
 
 <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>]</SMALL>
 _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></FONT>に変更";
 }
 
 if ($actor eq '' || $color eq '') {
     &error("編集人物名または色が選ばれていません");
 }
 
 if ($name eq '' && $color ne 'no') {
     &error("何も書かれていないか、または使用禁止の文字が使われているようです。&lt;は使用しないでください。");
 }
 
 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]』</B></FONT>が$mesされましたわよ</H2>
 
 </CENTER>
 
 <P>
 <SMALL>[<A HREF="doraedit.cgi?pass=$pw">もどる</A>]</SMALL>
 _EOF_
 exit;
 }
 
 # ***************************
 # 禁止文字コードの変換処理
 # ***************************
 
 sub change0 {
     local($text) = $_[0];
     $text =~ s/\(/&#40;/g;
     $text =~ s/\)/&#41;/g;
     $text =~ s/\*/&#42;/g;
     $text =~ s/\+/&#43;/g;
     $text =~ s/\./&#46;/g;
     $text =~ s/\?/&#63;/g;
     $text =~ s/\[/&#91;/g;
     $text =~ s/\\/&#92;/g;
     $text =~ s/\]/&#93;/g;
     $text =~ s/\{/&#123;/g;
     $text =~ s/\|/&#124;/g;
     $text =~ s/\}/&#125;/g;
     return $text;
 }
 
 sub change1 {
     local($text) = $_[0];
     $text =~ s/&#40;/\(/g;
     $text =~ s/&#41;/\)/g;
     $text =~ s/&#42;/\*/g;
     $text =~ s/&#43;/\+/g;
     $text =~ s/&#46;/\./g;
     $text =~ s/&#63;/\?/g;
     $text =~ s/&#91;/\[/g;
     $text =~ s/&#92;/\\/g;
     $text =~ s/&#93;/\]/g;
     $text =~ s/&#123;/\{/g;
     $text =~ s/&#124;/\|/g;
     $text =~ s/&#125;/\}/g;
     return $text;
 }
 
 # ***************************
 # エラー処理
 # ***************************
 
 sub error {
 print <<"_HTML_error_";
 <H2>エラーが発生しました。</H2>
 $_[0]
 </BODY></HTML>
 _HTML_error_
 exit;
 }

*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/img/download/dl_icon.gif,left,nolink,18x18,kyara.log);kyara.log:http://webdoramamuseum.s1003.xrea.com/common/cgi-bin/link/perldnload.cgi?dlfile=http://webdoramamuseum.s1003.xrea.com/common/file/dorama-plus/kyara_log.txt&dlname=kyara_log.txt]] [#g8630eac]

 A夫<>#0000FF
 B子<>#FF0000
 C助<>#008800
 D美<>#FF0000
 ナレーション<>#000000
 効果音<>#008000

*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/img/download/dl_icon.gif,left,nolink,18x18,dorama.log);dorama.log:http://webdoramamuseum.s1003.xrea.com/common/cgi-bin/link/perldnload.cgi?dlfile=http://webdoramamuseum.s1003.xrea.com/common/file/dorama-plus/dorama_log.txt&dlname=dorama_log.txt]] [#s34f5b58]

  

*** [[&ref(http://webdoramamuseum.s1003.xrea.com/common/img/download/dl_icon.gif,left,nolink,18x18,jcode.pl);jcode.pl:http://webdoramamuseum.s1003.xrea.com/common/cgi-bin/link/perldnload.cgi?dlfile=http://webdoramamuseum.s1003.xrea.com/common/file/dorama-plus/jcode_pl.txt&dlname=jcode_pl.txt]] [#i7301dae]

 package jcode;
 ;######################################################################
 ;#
 ;# jcode.pl: Perl library for Japanese character code conversion
 ;#
 ;# Copyright (c) 1995,1996 Kazumasa Utashiro <utashiro@iij.ad.jp>
 ;# 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 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.
 ;#
 ;; $rcsid = q$Id: jcode.pl,v 2.0 1996/10/02 16:02:38 utashiro Rel $;
 ;#
 ;######################################################################
 ;#
 ;# 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 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(@readahead, $_);
 ;#	    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_jp   = '\e\$[\@B]';
     $re_asc  = '\e\([BJ]';
     $re_kana = '\e\(I';
     ($esc_jp, $esc_asc, $esc_kana) = ("\e\$B", "\e(B", "\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]';
 
     # These variables are retained only for backward compatibility.
     $re_euc_s = "($re_euc_c)+";
     $re_sjis_s = "($re_sjis_c)+";
 
     $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/\021-\176/\221-\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;
 
     $_ = '';
     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_${f};\n";
     }
     eval $_;
 }
 
 ;#
 ;# Set escape sequences which should be put before and after Japanese
 ;# (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<=>$euc) + $[ + 1]);
 }
 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(*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($&)/geo) {
 	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)/geo;
     &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)/geo;
     $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($&)/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/$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+,<])+/&__z2h_jis($&)/ge;
     $_;
 }
 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_euc{$&}) : $&/geo;
     $n;
 }
 
 sub z2h_sjis {
     local(*_, $n) = @_;
     &init_z2h_sjis unless defined %z2h_sjis;
     s/$re_sjis_c/$z2h_sjis{$&} ? ($n++, $z2h_sjis{$&}) : $&/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$&/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 {
     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]/&_expnd2($&)/ge, $from, $to);
     grep(s/$ascii-$ascii/&_expnd1($&)/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;
 
     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/img/download/dl_icon.gif,left,nolink,18x18,dorama.gif);dorama.gif:http://webdoramamuseum.s1003.xrea.com/common/cgi-bin/link/perldnload.cgi?dlfile=http://webdoramamuseum.s1003.xrea.com/common/file/dorama-plus/dorama.gif&dlname=dorama.gif]] [#jf81abc2]

&ref(http://webdoramamuseum.s1003.xrea.com/common/img/cgi/dorama.gif,left,around,nolink,800x40,dorama.gif);

** File [#q41e61ea]

とりあえず代理で配布する。~
Perlをかじった上で触れたことがある者なら何が不足しているか理解はできるものの、~
登場人物にHTMLタグが登録されると言う脆弱性により書き込めなくなる等の責任は負えない。~
~
CENTER:それでもよければダウンロードしてもいい…

- [[&ref(http://webdoramamuseum.s1003.xrea.com/common/img/download/dl_lzh.gif,left,nolink,16x16,dorama-plus.lzh);dorama-plus.lzh:http://webdoramamuseum.s1003.xrea.com/common/cgi-bin/link/perldnload.cgi?dlfile=http://webdoramamuseum.s1003.xrea.com/common/file/dorama-plus.lzh&dlname=dorama-plus.lzh]]
[[&ref(http://webdoramamuseum.s1003.xrea.com/common/img/download/dl_zip.gif,left,nolink,16x16,dorama-plus.zip);dorama-plus.zip:http://webdoramamuseum.s1003.xrea.com/common/cgi-bin/link/perldnload.cgi?dlfile=http://webdoramamuseum.s1003.xrea.com/common/file/dorama-plus.zip&dlname=dorama-plus.zip]]

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/dorama/dorama-plus.cgi]]
[[体験版>http://webdoramamuseum.s1003.xrea.com/cgi-bin/dorama/dorama-plus.cgi]]~
~
体験版と銘打っていますが、一部のみ改修しています。

** 最後に… [#jdfa8953]

いかなる場合でもこのスクリプトの商用利用ならびに未改造設置は禁止する。~
理由は、トラブルの温床であると共にいつ投稿不可能に陥るかが不明である事だ。

* 関連ページ [#e0ced47c]

#related

トップ   編集 差分 履歴 添付 複製 名前変更 リロード   新規 一覧 検索 最終更新   ヘルプ   最終更新のRSS
警告:くれぐれもまとめサイトに転載・記載するのだけはおやめください。