Easy Form

Easy Form 1.22

■easyform.cgi：コピーして拡張子をcgiにしてEUC-JPで保存してください。
#!/usr/local/bin/perl #この最初の１行はプロバイダによって違いますので確認してください。 #２行目は必ず空行にしておいてください。 #このスクリプトはPerl5を使っています。 ######################################## # #Easy Form ver1.22 # # Atelier H # http://www.atsh.com/ # info@atsh.com # #※このスクリプトの著作権はAtelier Hにあります。 # ######################################## #日本語変換ライブラリの呼び出し require 'jcode.pl'; require 'cgi-lib.pl'; require 'mimew.pl'; #初期設定(必要に応じて変更してください) #このスクリプトの名前 $script = 'easyform.cgi'; #メールフォームのページ $home = '../eform.html'; #管理者のメールアドレス $address = '***@mail.co.jp'; #必須項目の設定。カンマで区切って指定したい項目を増やせます。 @CHECK = ('お名前','Email'); #<BODY>の設定 $body = '<BODY BGCOLOR="#FFFFFF" TEXT="#000099">'; #sendmailのパス $mailer = '/usr/sbin/sendmail'; #差出人の名前 $from = "****"; #メールの件名 #半角カンマは使用しないでください。 $subject = "メールフォーム"; #テーブルの幅 $wsize = 560; #テーブルのセルの色 $bgcolor = '#CCCCCC'; ###初期設定ここまで### ############################################################################################# # #ディレクトリ構造 # #public_html # ｜ # easy.html # cgi-bin # ｜ # jcode.pl(ASCII／755) # cgi-lib.pl(ASCII／755) # mimew.pl(ASCII／755) # easyform.cgi(ASCII／755) # #ファイルの位置関係を変えた場合は、初期設定でそれぞれのファイルを相対パスで指定してください。 #パーミッションの設定は、プロバイダによって異なる場合があります。 #上手く動作しなかった場合はプロバイダに確認してください。 # ############################################################################################# chop($date = `date`); ReadParse(*QUERY); while (($key, $value) = each %QUERY) { if ($key =~ /file/i || $key =~ /upload/i) { next; } $value =~ s/\n//g; $value =~ s/\t//g; jcode'convert(*key,'euc'); jcode'convert(*value,'euc'); $QUERY{$key} = $value; } print "Content-type: text/html\n\n"; if($QUERY{'act'} == 1){ &confirm; } elsif($QUERY{'act'} == 2){ &send; } else{ &error("このスクリプトは$subjectのページからご利用ください。"); } sub confirm{ if(@CHECK) { foreach (@CHECK) { if (!$QUERY{$_}) { &error("$_を記入してください"); } } } if($QUERY{'Email'} !~ /^[\w\-.]+\@[\w\-.]+\.[\w\-.]+$/){ &error('メールアドレスを正しく記入してください。'); } &head; print <<"EOF"; <CENTER> <FORM METHOD="post" ACTION="$script"> <TABLE WIDTH="$wsize" BORDER="0" CELLPADDING="2" CELLSPACING="2"> <TR> <TH COLSPAN ="2">内容を確認してください。</TH> </TR> EOF while(($key, $value) = each %QUERY){ if($key ne 'act' and $value ne ""){ $value =~ s/\0/,/g; print " <TR BGCOLOR=\"$bgcolor\">\n"; print " <TD><INPUT TYPE=\"hidden\" NAME=\"$key\" VALUE=\"$value\">\n"; print " $key</TD>\n"; $value =~ s/\r/<BR>/g; print " <TD>$value</TD>\n"; print " </TR>\n"; } } print <<"EOF"; <TR> <TD COLSPAN="2" ALIGN="center"> <INPUT TYPE="hidden" NAME="act" VALUE="2"> <INPUT TYPE="submit" VALUE="送信する"> </TD> </TR> </TABLE> </FORM> </CENTER> EOF &food; } sub send{ while (($key, $value) = each %QUERY) { if($key ne 'act'){ $value =~ s/\r/\n/g; $value =~ s/\0/ /g; $coment .= "$key\:$value\n"; } } &head; print <<"EOF"; <CENTER> 送信完了いたしました。 <FONT COLOR="red">※メールアドレスが間違っていると届きません。</FONT> </CENTER> EOF &food; $subject = mimeencode($subject); jcode'convert(*msg,'jis'); if (!open(MAIL, "|$mailer $address")) { &error('送信できませんでした。'); } print MAIL "Reply-to: $address\n"; print MAIL "Subject: $subject\n"; print MAIL "From: $from<$address>\n"; print MAIL "To: $address\n"; print MAIL "Errors-To: $address\n"; print MAIL "MIME-Version: 1.0\n"; print MAIL "Content-Type: text/plain;charset=\"iso-2022-jp\"\n"; print MAIL "Content-Transfer-Encoding: 7bit\n"; print MAIL "\n\n$date\n"; print MAIL $coment; } sub head{ print <<"EOF"; <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"> <HTML LANG="ja"> <HEAD> <META NAME="reply-to" CONTENT="$address"> <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=EUC-JP"> <SCRIPT language="JavaScript">  </SCRIPT> EOF } sub food{ #コピーライツです。削除しないでください。 print <<"EOF"; <HR WIDTH="$wsize"> <TABLE WIDTH="$wsize" BORDER="0" ALIGN="center"> <TR> <TD><A HREF="$home">HOME</A></TD> <TD ALIGN="right"> <FONT SIZE="2"><I>Random Form (c)<A HREF="mailto:info\@atsh.com">Atelier H</A></I></FONT> </TD> </TR> </TABLE> </BODY> </HTML> EOF } sub error{ &head; print <<"EOF"; <TITLE>エラー</TITLE> </HEAD> $body <CENTER> <FONT SIZE="3"><FONT COLOR="#FF0000">エラー</FONT><BR> $_[0]</FONT> <FORM> <INPUT TYPE="button" onClick="PageBack()" VALUE=" 戻る "> </FORM> </CENTER> EOF &food; exit; }

■eform.html：入力フォームのHTMLサンプル。任意に変更してください。(EUC-JPで保存してください)
<HTML> <HEAD> <META HTTP-EQUIV="Content-Type" CONTENT="text/html; CHARSET=euc-jp"> <TITLE>Easy Form</TITLE> </HEAD> <CENTER> <FORM METHOD="post" ACTION="cgi-bin/easyform.cgi"> <TABLE WIDTH="560" BORDER="0" CELLSPACING="2" CELLPADDING="2"> <TR> <TH COLSPAN="2"><FONT SIZE="4">メールフォームサンプル１</FONT><BR> <FONT SIZE="3">もっとも基本的なメールフォームです。</FONT><BR> <FONT SIZE="2" COLOR="#FF3300">お名前とメールアドレスは必ずお書きください。</FONT></TH> </TR> <TR BGCOLOR="#EEFFFF"> <TD BGCOLOR="#EEFFFF" ALIGN="RIGHT"><FONT SIZE="2">お名前</FONT> </TD> <TD BGCOLOR="#EEFFFF"> <INPUT TYPE="text" NAME="お名前" SIZE="30"> </TD> </TR> <TR BGCOLOR="#EEFFFF"> <TD BGCOLOR="#EEFFFF" ALIGN="RIGHT"><FONT SIZE="2">メールアドレス</FONT> </TD> <TD BGCOLOR="#EEFFFF"> <INPUT TYPE="text" NAME="Email" SIZE="30"> </TD> </TR> <TR BGCOLOR="#EEFFFF"> <TD BGCOLOR="#EEFFFF" ALIGN="RIGHT"><FONT SIZE="2">件名</FONT> </TD> <TD BGCOLOR="#EEFFFF"> <INPUT TYPE="text" NAME="件名" SIZE="30"> </TD> </TR> <TR BGCOLOR="#EEFFFF"> <TD BGCOLOR="#EEFFFF" VALIGN="TOP" ALIGN="RIGHT"><FONT SIZE="2">内容</FONT> </TD> <TD BGCOLOR="#EEFFFF" VALIGN="TOP"> <TEXTAREA NAME="内容" COLS="30" ROWS="4"></TEXTAREA> </TD> </TR> <TR BGCOLOR="#EEFFFF" ALIGN="CENTER"> <TD COLSPAN="2" BGCOLOR="#EEFFFF"> <INPUT TYPE="hidden" NAME="act" VALUE="1"> <INPUT TYPE="submit" VALUE="送信する"> <INPUT TYPE="RESET" VALUE="リセット"> </TD> </TR> </TABLE> </FORM> <HR WIDTH="560" SIZE="1" NOSHADE> <CENTER> <FORM METHOD="post" ACTION="../cgibin/easyform.cgi"> <TABLE WIDTH="560" BORDER="0" CELLSPACING="2" CELLPADDING="2"> <TR> <TH COLSPAN="2"><FONT SIZE="4">メールフォームサンプル２</FONT><BR> <FONT SIZE="3">アンケートなどの質問用フォームです。</FONT><BR> <FONT SIZE="2" COLOR="#FF3300"><必須>と書かれた項目はすべてお書きください。</FONT></TH> </TR> <TR BGCOLOR="#EEFFFF"> <TD BGCOLOR="#EEFFFF" VALIGN="TOP"> <P><FONT SIZE="2">Ｑ１：Atelier Hは何でお知りになりましたか？</FONT></P> </TD> <TD BGCOLOR="#EEFFFF"> <SELECT NAME="Q1"> <OPTION SELECTED>項目を選んでください</OPTION> <OPTION VALUE="検索エンジン">検索エンジン</OPTION> <OPTION VALUE="ＨＰのリンク">ＨＰのリンク</OPTION> <OPTION VALUE="掲示板、ＭＬ">掲示板、ＭＬ</OPTION> <OPTION VALUE="その他">その他</OPTION> </SELECT> </TD> </TR> <TR BGCOLOR="#EEFFFF"> <TD BGCOLOR="#EEFFFF" VALIGN="TOP"><FONT SIZE="2">Ｑ２：内容はお役に立てましたか？</FONT></TD> <TD BGCOLOR="#EEFFFF"> <FONT SIZE="2"> <INPUT TYPE="radio" NAME="Q2" VALUE="とても役に立った"> とても役に立った／ <INPUT TYPE="radio" NAME="Q2" VALUE="そこそこ役に立った"> そこそこ役に立った／<BR> <INPUT TYPE="radio" NAME="Q2" VALUE="イマイチだった"> イマイチだった／ <INPUT TYPE="radio" NAME="Q2" VALUE="オチがなかった"> オチがなかった(^-^;;</FONT></TD> </TR> <TR BGCOLOR="#EEFFFF"> <TD BGCOLOR="#EEFFFF" VALIGN="TOP"><FONT SIZE="2">Ｑ３：新たに知りたいジャンルはありますか？</FONT></TD> <TD BGCOLOR="#EEFFFF"> <FONT SIZE="2"> <INPUT TYPE="checkbox" NAME="Q31" VALUE="Flash"> Flash／ <INPUT TYPE="checkbox" NAME="Q32" VALUE="ＸＭＬ"> XML／ <INPUT TYPE="checkbox" NAME="Q33" VALUE="プログラミング"> プログラミング／ <INPUT TYPE="checkbox" NAME="Q34" VALUE="データベース"> データベース／ <INPUT TYPE="checkbox" NAME="Q35" VALUE="その他"> その他</FONT></TD> </TR> <TR BGCOLOR="#EEFFFF"> <TD BGCOLOR="#EEFFFF" VALIGN="TOP"><FONT SIZE="2">その他のご意見(Q1、Q3でその他を選んだ方もよろしければ具体的に教えてください)</FONT></TD> <TD BGCOLOR="#EEFFFF" VALIGN="TOP"> <TEXTAREA NAME="意見" COLS="30" ROWS="4"></TEXTAREA> </TD> </TR> <TR BGCOLOR="#EEFFFF"> <TD BGCOLOR="#EEFFFF"><FONT SIZE="2">お名前<FONT COLOR="#FF3300"><必須></FONT></FONT> </TD> <TD BGCOLOR="#EEFFFF"> <INPUT TYPE="text" NAME="お名前" SIZE="30"> </TD> </TR> <TR BGCOLOR="#EEFFFF"> <TD BGCOLOR="#EEFFFF"><FONT SIZE="2">メールアドレス<FONT COLOR="#FF3300"><必須></FONT></FONT> </TD> <TD BGCOLOR="#EEFFFF"> <INPUT TYPE="text" NAME="Email" SIZE="30"> </TD> </TR> <TR BGCOLOR="#EEFFFF"> <TD COLSPAN="2" BGCOLOR="#EEFFFF" ALIGN="CENTER"> <INPUT TYPE="hidden" NAME="act" VALUE="1"> <INPUT TYPE="submit" VALUE="送信する"> <INPUT TYPE="RESET" VALUE="リセット"> </TD> </TR> <TR> <TD COLSPAN="2"> <FONT SIZE="2">＊アンケートの内容は本来管理人に送られますが、このサンプルでは、記入した本人にも内容を書いたものが送られます。</FONT> </TD> </TR> </TABLE> </FORM> </CENTER> <TABLE WIDTH="560" BORDER="0" CELLSPACING="0" CELLPADDING="0"> <TR> <TD> <DIV ALIGN="center"><FONT SIZE="2">お問い合わせは<A HREF="mailto:info@atsh.com">Atelier H<info@atsh.com></A>まで</FONT> <HR SIZE="1" NOSHADE> </DIV> <FONT SIZE="2"><A HREF="index.shtml">TOPページへ戻る</A></FONT> </TD> </TR> </TABLE> </CENTER> </BODY> </HTML>

■jcode.pl
package jcode; ;###################################################################### ;# ;# jcode.pl: Perl library for Japanese character code conversion ;# ;# Copyright (c) 1995-2000 Kazumasa Utashiro <utashiro@iij.ad.jp> ;# Internet Initiative Japan Inc. ;# 3-13 Kanda Nishiki-cho, Chiyoda-ku, Tokyo 101-0054, Japan ;# ;# Copyright (c) 1992,1993,1994 Kazumasa Utashiro ;# Software Research Associates, Inc. ;# ;# Use and redistribution for ANY PURPOSE are granted as long as all ;# copyright notices are retained. Redistribution with modification ;# is allowed provided that you make your modified version obviously ;# distinguishable from the original one. THIS SOFTWARE IS PROVIDED ;# BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES ARE ;# DISCLAIMED. ;# ;# Original version was developed under the name of srekcah@sra.co.jp ;# February 1992 and it was called kconv.pl at the beginning. This ;# address was a pen name for group of individuals and it is no longer ;# valid. ;# ;# The latest version is available here: ;# ;# ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/ ;# ;; $rcsid = q$Id: jcode.pl,v 2.13 2000/09/29 16:10:05 utashiro Exp $; ;# ;###################################################################### ;# ;# PERL4 INTERFACE: ;# ;# &jcode'getcode(*line) ;# Return 'jis', 'sjis', 'euc' or undef according to ;# Japanese character code in $line. Return 'binary' if ;# the data has non-character code. ;# ;# When evaluated in array context, it returns a list ;# contains two items. First value is the number of ;# characters which matched to the expected code, and ;# second value is the code name. It is useful if and ;# only if the number is not 0 and the code is undef; ;# that case means it couldn't tell 'euc' or 'sjis' ;# because the evaluation score was exactly same. This ;# interface is too tricky, though. ;# ;# Code detection between euc and sjis is very difficult ;# or sometimes impossible or even lead to wrong result ;# when it includes JIS X0201 KANA characters. So JIS ;# X0201 KANA is ignored for automatic code detection. ;# ;# &jcode'convert(*line, $ocode [, $icode [, $option]]) ;# Convert the contents of $line to the specified ;# Japanese code given in the second argument $ocode. ;# $ocode can be any of "jis", "sjis" or "euc", or use ;# "noconv" when you don't want the code conversion. ;# Input code is recognized automatically from the line ;# itself when $icode is not supplied (JIS X0201 KANA is ;# ignored in code detection. See the above descripton ;# of &getcode). $icode also can be specified, but ;# xxx2yyy routine is more efficient when both codes are ;# known. ;# ;# It returns the code of input string in scalar context, ;# and a list of pointer of convert subroutine and the ;# input code in array context. ;# ;# Japanese character code JIS X0201, X0208, X0212 and ;# ASCII code are supported. X0212 characters can not be ;# represented in SJIS and they will be replased by ;# "geta" character when converted to SJIS. ;# ;# See next paragraph for $option parameter. ;# ;# &jcode'xxx2yyy(*line [, $option]) ;# Convert the Japanese code from xxx to yyy. String xxx ;# and yyy are any convination from "jis", "euc" or ;# "sjis". They return *approximate* number of converted ;# bytes. So return value 0 means the line was not ;# converted at all. ;# ;# Optional parameter $option is used to specify optional ;# conversion method. String "z" is for JIS X0201 KANA ;# to X0208 KANA, and "h" is for reverse. ;# ;# $jcode'convf{'xxx', 'yyy'} ;# The value of this associative array is pointer to the ;# subroutine jcode'xxx2yyy(). ;# ;# &jcode'to($ocode, $line [, $icode [, $option]]) ;# &jcode'jis($line [, $icode [, $option]]) ;# &jcode'euc($line [, $icode [, $option]]) ;# &jcode'sjis($line [, $icode [, $option]]) ;# These functions are prepared for easy use of ;# call/return-by-value interface. You can use these ;# funcitons in s///e operation or any other place for ;# convenience. ;# ;# &jcode'jis_inout($in, $out) ;# Set or inquire JIS start and end sequences. Default ;# is "ESC-$-B" and "ESC-(-B". If you supplied only one ;# character, "ESC-$" or "ESC-(" is prepended for each ;# character respectively. Acutually "ESC-(-B" is not a ;# sequence to end JIS code but a sequence to start ASCII ;# code set. So `in' and `out' are somewhat misleading. ;# ;# &jcode'get_inout($string) ;# Get JIS start and end sequences from $string. ;# ;# &jcode'cache() ;# &jcode'nocache() ;# &jcode'flush() ;# Usually, converted character is cached in memory to ;# avoid same calculations have to be done many times. ;# To disable this caching, call &jcode'nocache(). It ;# can be revived by &jcode'cache() and cache is flushed ;# by calling &jcode'flush(). &cache() and &nocache() ;# functions return previous caching state. ;# ;# --------------------------------------------------------------- ;# ;# &jcode'h2z_xxx(*line) ;# JIS X0201 KANA (so-called Hankaku-KANA) to X0208 KANA ;# (Zenkaku-KANA) code conversion routine. String xxx is ;# any of "jis", "sjis" and "euc". From the difficulty ;# of recognizing code set from 1-byte KATAKANA string, ;# automatic code recognition is not supported. ;# ;# &jcode'z2h_xxx(*line) ;# X0208 to X0201 KANA code conversion routine. String ;# xxx is any of "jis", "sjis" and "euc". ;# ;# $jcode'z2hf{'xxx'} ;# $jcode'h2zf{'xxx'} ;# These are pointer to the corresponding function just ;# as $jcode'convf. ;# ;# --------------------------------------------------------------- ;# ;# &jcode'tr(*line, $from, $to [, $option]) ;# &jcode'tr emulates tr operator for 2 byte code. Only 'd' ;# is interpreted as an option. ;# ;# Range operator like `A-Z' for 2 byte code is partially ;# supported. Code must be JIS or EUC, and first byte ;# have to be same on first and last character. ;# ;# CAUTION: Handling range operator is a kind of trick ;# and it is not perfect. So if you need to transfer `-' ;# character, please be sure to put it at the beginning ;# or the end of $from and $to strings. ;# ;# &jcode'trans($line, $from, $to [, $option) ;# Same as &jcode'tr but accept string and return string ;# after translation. ;# ;# --------------------------------------------------------------- ;# ;# &jcode'init() ;# Initialize the variables used in this package. You ;# don't have to call this when using jocde.pl by `do' or ;# `require' interface. Call it first if you embedded ;# the jcode.pl at the end of your script. ;# ;###################################################################### ;# ;# PERL5 INTERFACE: ;# ;# Current jcode.pl is written in Perl 4 but it is possible to use ;# from Perl 5 using `references'. Fully perl5 capable version is ;# future issue. ;# ;# Since lexical variable is not a subject of typeglob, *string style ;# call doesn't work if the variable is declared as `my'. Same thing ;# happens to special variable $_ if the perl is compiled to use ;# thread capability. So using reference is generally recommented to ;# avoid the mysterious error. ;# ;# jcode::getcode(\$line) ;# jcode::convert(\$line, $ocode [, $icode [, $option]]) ;# jcode::xxx2yyy(\$line [, $option]) ;# &{$jcode::convf{'xxx', 'yyy'}}(\$line) ;# jcode::to($ocode, $line [, $icode [, $option]]) ;# jcode::jis($line [, $icode [, $option]]) ;# jcode::euc($line [, $icode [, $option]]) ;# jcode::sjis($line [, $icode [, $option]]) ;# jcode::jis_inout($in, $out) ;# jcode::get_inout($string) ;# jcode::cache() ;# jcode::nocache() ;# jcode::flush() ;# jcode::h2z_xxx(\$line) ;# jcode::z2h_xxx(\$line) ;# &{$jcode::z2hf{'xxx'}}(\$line) ;# &{$jcode::h2zf{'xxx'}}(\$line) ;# jcode::tr(\$line, $from, $to [, $option]) ;# jcode::trans($line, $from, $to [, $option) ;# jcode::init() ;# ;###################################################################### ;# ;# SAMPLES ;# ;# Convert any Kanji code to JIS and print each line with code name. ;# ;# while (defined($s = <>)) { ;# $code = &jcode'convert(*s, 'jis'); ;# print $code, "\t", $s; ;# } ;# ;# Convert all lines to JIS according to the first recognized line. ;# ;# while (defined($s = <>)) { ;# print, next unless $s =~ /[\033\200-\377]/; ;# (*f, $icode) = &jcode'convert(*s, 'jis'); ;# print; ;# defined(&f) || next; ;# while (<>) { &f(*s); print; } ;# last; ;# } ;# ;# The safest way of JIS conversion. ;# ;# while (defined($s = <>)) { ;# ($matched, $icode) = &jcode'getcode(*s); ;# if (@buf == 0 && $matched == 0) { ;# print $s; ;# next; ;# } ;# push(@buf, $s); ;# next unless $icode; ;# while (defined($s = shift(@buf))) { ;# &jcode'convert(*s, 'jis', $icode); ;# print $s; ;# } ;# while (defined($s = <>)) { ;# &jcode'convert(*s, 'jis', $icode); ;# print $s; ;# } ;# last; ;# } ;# print @buf if @buf; ;# ;###################################################################### ;# ;# 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 : 'unknown'; $re_bin = '[\000-\006\177\377]'; $re_jis0208_1978 = '\e\$\@'; $re_jis0208_1983 = '\e\$B'; $re_jis0208_1990 = '\e&\@\e\$B'; $re_jis0208 = "$re_jis0208_1978|$re_jis0208_1983|$re_jis0208_1990"; $re_jis0212 = '\e\$\(D'; $re_jp = "$re_jis0208|$re_jis0212"; $re_asc = '\e\([BJ]'; $re_kana = '\e\(I'; $esc_0208 = "\e\$B"; $esc_0212 = "\e\$(D"; $esc_asc = "\e(B"; $esc_kana = "\e(I"; $re_sjis_c = '[\201-\237\340-\374][\100-\176\200-\374]'; $re_sjis_kana = '[\241-\337]'; $re_euc_c = '[\241-\376][\241-\376]'; $re_euc_kana = '\216[\241-\337]'; $re_euc_0212 = '\217[\241-\376][\241-\376]'; # Use `geta' for undefined character code $undef_sjis = "\x81\xac"; $cache = 1; # X0201 -> X0208 KANA conversion table. Looks weird? Not that # much. This is simply JIS text without escape sequences. ($h2z_high = $h2z = <<'__TABLE_END__') =~ tr/\041-\176/\241-\376/; ! !# $ !" % !& " !V # !W ^ !+ _ !, 0 !< ' %! ( %# ) %% * %' + %) , %c - %e . %g / %C 1 %" 2 %$ 3 %& 4 %( 5 %* 6 %+ 7 %- 8 %/ 9 %1 : %3 6^ %, 7^ %. 8^ %0 9^ %2 :^ %4 ; %5 < %7 = %9 > %; ? %= ;^ %6 <^ %8 =^ %: >^ %< ?^ %> @ %? A %A B %D C %F D %H @^ %@ A^ %B B^ %E C^ %G D^ %I E %J F %K G %L H %M I %N J %O K %R L %U M %X N %[ J^ %P K^ %S L^ %V M^ %Y N^ %\ J_ %Q K_ %T L_ %W M_ %Z N_ %] O %^ P %_ Q %` R %a S %b T %d U %f V %h W %i X %j Y %k Z %l [ %m \ %o ] %s & %r 3^ %t __TABLE_END__ %h2z = split(/\s+/, $h2z . $h2z_high); %z2h = reverse %h2z; $convf{'jis' , 'jis' } = *jis2jis; $convf{'jis' , 'sjis'} = *jis2sjis; $convf{'jis' , 'euc' } = *jis2euc; $convf{'euc' , 'jis' } = *euc2jis; $convf{'euc' , 'sjis'} = *euc2sjis; $convf{'euc' , 'euc' } = *euc2euc; $convf{'sjis' , 'jis' } = *sjis2jis; $convf{'sjis' , 'sjis'} = *sjis2sjis; $convf{'sjis' , 'euc' } = *sjis2euc; $h2zf{'jis' } = *h2z_jis; $z2hf{'jis' } = *z2h_jis; $h2zf{'euc' } = *h2z_euc; $z2hf{'euc' } = *z2h_euc; $h2zf{'sjis'} = *h2z_sjis; $z2hf{'sjis'} = *z2h_sjis; } ;# ;# Set escape sequences which should be put before and after Japanese ;# (JIS X0208) string. ;# sub jis_inout { $esc_0208 = shift || $esc_0208; $esc_0208 = "\e\$$esc_0208" if length($esc_0208) == 1; $esc_asc = shift || $esc_asc; $esc_asc = "\e\($esc_asc" if length($esc_asc) == 1; ($esc_0208, $esc_asc); } ;# ;# Get JIS in and out sequences from the string. ;# sub get_inout { local($esc_0208, $esc_asc); $_[$[] =~ /($re_jis0208)/o && ($esc_0208 = $1); $_[$[] =~ /($re_asc)/o && ($esc_asc = $1); ($esc_0208, $esc_asc); } ;# ;# Recognize character code. ;# sub getcode { local(*s) = @_; local($matched, $code); if ($s !~ /[\e\200-\377]/) { # not Japanese $matched = 0; $code = undef; } # 'jis' elsif ($s =~ /$re_jp|$re_asc|$re_kana/o) { $matched = 1; $code = 'jis'; } elsif ($s =~ /$re_bin/o) { # 'binary' $matched = 0; $code = 'binary'; } else { # should be 'euc' or 'sjis' local($sjis, $euc) = (0, 0); while ($s =~ /(($re_sjis_c)+)/go) { $sjis += length($1); } while ($s =~ /(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/go) { $euc += length($1); } $matched = &max($sjis, $euc); $code = ('euc', undef, 'sjis')[($sjis<=>$euc) + $[ + 1]; } wantarray ? ($matched, $code) : $code; } sub max { $_[ $[ + ($_[ $[ ] < $_[ $[ + 1 ]) ]; } ;# ;# Convert any code to specified code. ;# sub convert { local(*s, $ocode, $icode, $opt) = @_; return (undef, undef) unless $icode = $icode || &getcode(*s); return (undef, $icode) if $icode eq 'binary'; $ocode = 'jis' unless $ocode; $ocode = $icode if $ocode eq 'noconv'; local(*f) = $convf{$icode, $ocode}; &f(*s, $opt); wantarray ? (*f, $icode) : $icode; } ;# ;# Easy return-by-value interfaces. ;# sub jis { &to('jis', @_); } sub euc { &to('euc', @_); } sub sjis { &to('sjis', @_); } sub to { local($ocode, $s, $icode, $opt) = @_; &convert(*s, $ocode, $icode, $opt); $s; } sub what { local($s) = @_; &getcode(*s); } sub trans { local($s) = shift; &tr(*s, @_); $s; } ;# ;# SJIS to JIS ;# sub sjis2jis { local(*s, $opt, $n) = @_; &sjis2sjis(*s, $opt) if $opt; $s =~ s/(($re_sjis_c|$re_sjis_kana)+)/&_sjis2jis($1) . $esc_asc/geo; $n; } sub _sjis2jis { local($s) = shift; $s =~ s/(($re_sjis_c)+|($re_sjis_kana)+)/&__sjis2jis($1)/geo; $s; } sub __sjis2jis { local($s) = shift; if ($s =~ /^$re_sjis_kana/o) { $n += $s =~ tr/\241-\337/\041-\137/; $esc_kana . $s; } else { $n += $s =~ s/($re_sjis_c)/$s2e{$1}||&s2e($1)/geo; $s =~ tr/\241-\376/\041-\176/; $esc_0208 . $s; } } ;# ;# EUC to JIS ;# sub euc2jis { local(*s, $opt, $n) = @_; &euc2euc(*s, $opt) if $opt; $s =~ s/(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/ &_euc2jis($1) . $esc_asc /geo; $n; } sub _euc2jis { local($s) = shift; $s =~ s/(($re_euc_c)+|($re_euc_kana)+|($re_euc_0212)+)/&__euc2jis($1)/geo; $s; } sub __euc2jis { local($s) = shift; local($esc); if ($s =~ tr/\216//d) { $esc = $esc_kana; } elsif ($s =~ tr/\217//d) { $esc = $esc_0212; } else { $esc = $esc_0208; } $n += $s =~ tr/\241-\376/\041-\176/; $esc . $s; } ;# ;# JIS to EUC ;# sub jis2euc { local(*s, $opt, $n) = @_; $s =~ s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2euc($1,$2)/geo; &euc2euc(*s, $opt) if $opt; $n; } sub _jis2euc { local($esc, $s) = @_; if ($esc !~ /^$re_asc/o) { $n += $s =~ tr/\041-\176/\241-\376/; if ($esc =~ /^$re_kana/o) { $s =~ s/([\241-\337])/\216$1/g; } elsif ($esc =~ /^$re_jis0212/o) { $s =~ s/([\241-\376][\241-\376])/\217$1/g; } } $s; } ;# ;# JIS to SJIS ;# sub jis2sjis { local(*s, $opt, $n) = @_; &jis2jis(*s, $opt) if $opt; $s =~ s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2sjis($1,$2)/geo; $n; } sub _jis2sjis { local($esc, $s) = @_; if ($esc =~ /^$re_jis0212/o) { $s =~ s/../$undef_sjis/g; $n = length; } elsif ($esc !~ /^$re_asc/o) { $n += $s =~ tr/\041-\176/\241-\376/; if ($esc =~ /^$re_jp/o) { $s =~ s/($re_euc_c)/$e2s{$1}||&e2s($1)/geo; } } $s; } ;# ;# SJIS to EUC ;# sub sjis2euc { local(*s, $opt,$n) = @_; $n = $s =~ s/($re_sjis_c|$re_sjis_kana)/$s2e{$1}||&s2e($1)/geo; &euc2euc(*s, $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(*s, $opt,$n) = @_; &euc2euc(*s, $opt) if $opt; $n = $s =~ s/($re_euc_c|$re_euc_kana|$re_euc_0212)/$e2s{$1}||&e2s($1)/geo; } sub e2s { local($c1, $c2, $code); ($c1, $c2) = unpack('CC', $code = shift); if ($c1 == 0x8e) { # SS2 return substr($code, 1, 1); } elsif ($c1 == 0x8f) { # SS3 return $undef_sjis; } elsif ($c1 % 2) { $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71); $c2 -= 0x60 + ($c2 < 0xe0); } else { $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70); $c2 -= 2; } if ($cache) { $e2s{$code} = pack('CC', $c1, $c2); } else { pack('CC', $c1, $c2); } } ;# ;# JIS to JIS, SJIS to SJIS, EUC to EUC ;# sub jis2jis { local(*s, $opt) = @_; $s =~ s/$re_jis0208/$esc_0208/go; $s =~ s/$re_asc/$esc_asc/go; &h2z_jis(*s) if $opt =~ /z/; &z2h_jis(*s) if $opt =~ /h/; } sub sjis2sjis { local(*s, $opt) = @_; &h2z_sjis(*s) if $opt =~ /z/; &z2h_sjis(*s) if $opt =~ /h/; } sub euc2euc { local(*s, $opt) = @_; &h2z_euc(*s) if $opt =~ /z/; &z2h_euc(*s) 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(*s, $n) = @_; if ($s =~ s/$re_kana([^\e]*)/$esc_0208 . &_h2z_jis($1)/geo) { 1 while $s =~ s/(($re_jis0208)[^\e]*)($re_jis0208)/$1/o; } $n; } sub _h2z_jis { local($s) = @_; $n += $s =~ s/(([\041-\137])([\136\137])?)/ $h2z{$1} || $h2z{$2} . $h2z{$3} /ge; $s; } sub h2z_euc { local(*s) = @_; $s =~ s/\216([\241-\337])(\216([\336\337]))?/ $h2z{"$1$3"} || $h2z{$1} . $h2z{$3} /ge; } sub h2z_sjis { local(*s, $n) = @_; $s =~ s/(($re_sjis_c)+)|(([\241-\337])([\336\337])?)/ $1 || ($n++, $h2z{$3} ? $e2s{$h2z{$3}} || &e2s($h2z{$3}) : &e2s($h2z{$4}) . ($5 && &e2s($h2z{$5}))) /geo; $n; } ;# ;# X0208 -> X0201 KANA conversion routine ;# sub z2h_jis { local(*s, $n) = @_; $s =~ s/($re_jis0208)([^\e]+)/&_z2h_jis($2)/geo; $n; } sub _z2h_jis { local($s) = @_; $s =~ s/((\%[!-~]|![\#\"&VW+,<])+|([^!%][!-~]|![^\#\"&VW+,<])+)/ &__z2h_jis($1) /ge; $s; } sub __z2h_jis { local($s) = @_; return $esc_0208 . $s unless $s =~ /^%/ || $s =~ /^![\#\"&VW+,<]/; $n += length($s) / 2; $s =~ s/(..)/$z2h{$1}/g; $esc_kana . $s; } sub z2h_euc { local(*s, $n) = @_; &init_z2h_euc unless defined %z2h_euc; $s =~ s/($re_euc_c|$re_euc_kana)/ $z2h_euc{$1} ? ($n++, $z2h_euc{$1}) : $1 /geo; $n; } sub z2h_sjis { local(*s, $n) = @_; &init_z2h_sjis unless defined %z2h_sjis; $s =~ s/($re_sjis_c)/$z2h_sjis{$1} ? ($n++, $z2h_sjis{$1}) : $1/geo; $n; } ;# ;# Initializing JIS X0208 to X0201 KANA table for EUC and SJIS. This ;# can be done in &init but it's not worth doing. Similarly, ;# precalculated table is not worth to occupy the file space and ;# reduce the readability. The author personnaly discourages to use ;# X0201 Kana character in the any situation. ;# sub init_z2h_euc { local($k, $s); while (($k, $s) = each %z2h) { $s =~ s/([\241-\337])/\216$1/g && ($z2h_euc{$k} = $s); } } sub init_z2h_sjis { local($s, $v); while (($s, $v) = each %z2h) { $s =~ /[\200-\377]/ && ($z2h_sjis{&e2s($s)} = $v); } } ;# ;# TR function for 2-byte code ;# sub tr { # $prev_from, $prev_to, %table are persistent variables local(*s, $from, $to, $opt) = @_; local(@from, @to); local($jis, $n) = (0, 0); $jis++, &jis2euc(*s) if $s =~ /$re_jp|$re_asc|$re_kana/o; $jis++ if $to =~ /$re_jp|$re_asc|$re_kana/o; if (!defined($prev_from) || $from ne $prev_from || $to ne $prev_to) { ($prev_from, $prev_to) = ($from, $to); undef %table; &_maketable; } $s =~ s/([\200-\377][\000-\377]|[\000-\377])/ defined($table{$1}) && ++$n ? $table{$1} : $1 /ge; &euc2jis(*s) if $jis; $n; } sub _maketable { local($ascii) = '(\\\\[\\-\\\\]|[\0-\133\135-\177])'; &jis2euc(*to) if $to =~ /$re_jp|$re_asc|$re_kana/o; &jis2euc(*from) if $from =~ /$re_jp|$re_asc|$re_kana/o; grep(s/(([\200-\377])[\200-\377]-\2[\200-\377])/&_expnd2($1)/ge, $from, $to); grep(s/($ascii-$ascii)/&_expnd1($1)/geo, $from, $to); @to = $to =~ /[\200-\377][\000-\377]|[\000-\377]/g; @from = $from =~ /[\200-\377][\000-\377]|[\000-\377]/g; push(@to, ($opt =~ /d/ ? '' : $to[$#to]) x (@from - @to)) if @to < @from; @table{@from} = @to; } sub _expnd1 { local($s) = @_; $s =~ s/\\(.)/$1/g; local($c1, $c2) = unpack('CxC', $s); if ($c1 <= $c2) { for ($s = ''; $c1 <= $c2; $c1++) { $s .= pack('C', $c1); } } $s; } sub _expnd2 { local($s) = @_; local($c1, $c2, $c3, $c4) = unpack('CCxCC', $s); if ($c1 == $c3 && $c2 <= $c4) { for ($s = ''; $c2 <= $c4; $c2++) { $s .= pack('CC', $c1, $c2); } } $s; } 1;

■cgi-lib.pl
# Perl Routines to Manipulate CGI input # cgi-lib@pobox.com # $Id: cgi-lib.pl,v 2.18 1999/02/23 08:16:43 brenner Exp $ # # Copyright (c) 1993-1999 Steven E. Brenner # Unpublished work. # Permission granted to use and modify this library so long as the # copyright above is maintained, modifications are documented, and # credit is given for any use of the library. # # Thanks are due to many people for reporting bugs and suggestions # For more information, see: # http://cgi-lib.stanford.edu/cgi-lib/ $cgi_lib'version = sprintf("%d.%02d", q$Revision: 2.18 $ =~ /(\d+)\.(\d+)/); # Parameters affecting cgi-lib behavior # User-configurable parameters affecting file upload. $cgi_lib'maxdata = 131072; # maximum bytes to accept via POST - 2^17 $cgi_lib'writefiles = 0; # directory to which to write files, or # 0 if files should not be written $cgi_lib'filepre = "cgi-lib"; # Prefix of file names, in directory above # Do not change the following parameters unless you have special reasons $cgi_lib'bufsize = 8192; # default buffer size when reading multipart $cgi_lib'maxbound = 100; # maximum boundary length to be encounterd $cgi_lib'headerout = 0; # indicates whether the header has been printed # ReadParse # Reads in GET or POST data, converts it to unescaped text, and puts # key/value pairs in %in, using "\0" to separate multiple selections # Returns >0 if there was input, 0 if there was no input # undef indicates some failure. # Now that cgi scripts can be put in the normal file space, it is useful # to combine both the form and the script in one place. If no parameters # are given (i.e., ReadParse returns FALSE), then a form could be output. # If a reference to a hash is given, then the data will be stored in that # hash, but the data from $in and @in will become inaccessable. # If a variable-glob (e.g., *cgi_input) is the first parameter to ReadParse, # information is stored there, rather than in $in, @in, and %in. # Second, third, and fourth parameters fill associative arrays analagous to # %in with data relevant to file uploads. # If no method is given, the script will process both command-line arguments # of the form: name=value and any text that is in $ENV{'QUERY_STRING'} # This is intended to aid debugging and may be changed in future releases sub ReadParse { # Disable warnings as this code deliberately uses local and environment # variables which are preset to undef (i.e., not explicitly initialized) local ($perlwarn); $perlwarn = $^W; $^W = 0; local (*in) = shift if @_; # CGI input local (*incfn, # Client's filename (may not be provided) *inct, # Client's content-type (may not be provided) *insfn) = @_; # Server's filename (for spooled files) local ($len, $type, $meth, $errflag, $cmdflag, $got, $name); binmode(STDIN); # we need these for DOS-based systems binmode(STDOUT); # and they shouldn't hurt anything else binmode(STDERR); # Get several useful env variables $type = $ENV{'CONTENT_TYPE'}; $len = $ENV{'CONTENT_LENGTH'}; $meth = $ENV{'REQUEST_METHOD'}; if ($len > $cgi_lib'maxdata) { #' &CgiDie("cgi-lib.pl: Request to receive too much data: $len bytes\n"); } if (!defined $meth || $meth eq '' || $meth eq 'GET' || $meth eq 'HEAD' || $type eq 'application/x-www-form-urlencoded') { local ($key, $val, $i); # Read in text if (!defined $meth || $meth eq '') { $in = $ENV{'QUERY_STRING'}; $cmdflag = 1; # also use command-line options } elsif($meth eq 'GET' || $meth eq 'HEAD') { $in = $ENV{'QUERY_STRING'}; } elsif ($meth eq 'POST') { if (($got = read(STDIN, $in, $len) != $len)) {$errflag="Short Read: wanted $len, got $got\n";}; } else { &CgiDie("cgi-lib.pl: Unknown request method: $meth\n"); } @in = split(/[&;]/,$in); push(@in, @ARGV) if $cmdflag; # add command-line parameters foreach $i (0 .. $#in) { # Convert plus to space $in[$i] =~ s/\+/ /g; # Split into key and value. ($key, $val) = split(/=/,$in[$i],2); # splits on the first =. # Convert %XX from hex numbers to alphanumeric $key =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge; $val =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge; # Associate key and value $in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple separator $in{$key} .= $val; } } elsif ($ENV{'CONTENT_TYPE'} =~ m#^multipart/form-data#) { # for efficiency, compile multipart code only if needed $errflag = !(eval <<'END_MULTIPART'); local ($buf, $boundary, $head, @heads, $cd, $ct, $fname, $ctype, $blen); local ($bpos, $lpos, $left, $amt, $fn, $ser); local ($bufsize, $maxbound, $writefiles) = ($cgi_lib'bufsize, $cgi_lib'maxbound, $cgi_lib'writefiles); # The following lines exist solely to eliminate spurious warning messages $buf = ''; ($boundary) = $type =~ /boundary="([^"]+)"/; #"; # find boundary ($boundary) = $type =~ /boundary=(\S+)/ unless $boundary; &CgiDie ("Boundary not provided: probably a bug in your server") unless $boundary; $boundary = "--" . $boundary; $blen = length ($boundary); if ($ENV{'REQUEST_METHOD'} ne 'POST') { &CgiDie("Invalid request method for multipart/form-data: $meth\n"); } if ($writefiles) { local($me); stat ($writefiles); $writefiles = "/tmp" unless -d _ && -w _; # ($me) = $0 =~ m#([^/]*)$#; $writefiles .= "/$cgi_lib'filepre"; } # read in the data and split into parts: # put headers in @in and data in %in # General algorithm: # There are two dividers: the border and the '\r\n\r\n' between # header and body. Iterate between searching for these # Retain a buffer of size(bufsize+maxbound); the latter part is # to ensure that dividers don't get lost by wrapping between two bufs # Look for a divider in the current batch. If not found, then # save all of bufsize, move the maxbound extra buffer to the front of # the buffer, and read in a new bufsize bytes. If a divider is found, # save everything up to the divider. Then empty the buffer of everything # up to the end of the divider. Refill buffer to bufsize+maxbound # Note slightly odd organization. Code before BODY: really goes with # code following HEAD:, but is put first to 'pre-fill' buffers. BODY: # is placed before HEAD: because we first need to discard any 'preface,' # which would be analagous to a body without a preceeding head. $left = $len; PART: # find each part of the multi-part while reading data while (1) { die $@ if $errflag; $amt = ($left > $bufsize+$maxbound-length($buf) ? $bufsize+$maxbound-length($buf): $left); $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt); die "Short Read: wanted $amt, got $got\n" if $errflag; $left -= $amt; $in{$name} .= "\0" if defined $in{$name}; $in{$name} .= $fn if $fn; $name=~/([-\w]+)/; # This allows $insfn{$name} to be untainted if (defined $1) { $insfn{$1} .= "\0" if defined $insfn{$1}; $insfn{$1} .= $fn if $fn; } BODY: while (($bpos = index($buf, $boundary)) == -1) { if ($left == 0 && $buf eq '') { foreach $value (values %insfn) { unlink(split("\0",$value)); } &CgiDie("cgi-lib.pl: reached end of input while seeking boundary " . "of multipart. Format of CGI input is wrong.\n"); } die $@ if $errflag; if ($name) { # if no $name, then it's the prologue -- discard if ($fn) { print FILE substr($buf, 0, $bufsize); } else { $in{$name} .= substr($buf, 0, $bufsize); } } $buf = substr($buf, $bufsize); $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf); $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt); die "Short Read: wanted $amt, got $got\n" if $errflag; $left -= $amt; } if (defined $name) { # if no $name, then it's the prologue -- discard if ($fn) { print FILE substr($buf, 0, $bpos-2); } else { $in {$name} .= substr($buf, 0, $bpos-2); } # kill last \r\n } close (FILE); last PART if substr($buf, $bpos + $blen, 2) eq "--"; substr($buf, 0, $bpos+$blen+2) = ''; $amt = ($left > $bufsize+$maxbound-length($buf) ? $bufsize+$maxbound-length($buf) : $left); $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt); die "Short Read: wanted $amt, got $got\n" if $errflag; $left -= $amt; undef $head; undef $fn; HEAD: while (($lpos = index($buf, "\r\n\r\n")) == -1) { if ($left == 0 && $buf eq '') { foreach $value (values %insfn) { unlink(split("\0",$value)); } &CgiDie("cgi-lib: reached end of input while seeking end of " . "headers. Format of CGI input is wrong.\n$buf"); } die $@ if $errflag; $head .= substr($buf, 0, $bufsize); $buf = substr($buf, $bufsize); $amt = ($left > $bufsize ? $bufsize : $left); #$maxbound==length($buf); $errflag = (($got = read(STDIN, $buf, $amt, length($buf))) != $amt); die "Short Read: wanted $amt, got $got\n" if $errflag; $left -= $amt; } $head .= substr($buf, 0, $lpos+2); push (@in, $head); @heads = split("\r\n", $head); ($cd) = grep (/^\s*Content-Disposition:/i, @heads); ($ct) = grep (/^\s*Content-Type:/i, @heads); ($name) = $cd =~ /\bname="([^"]+)"/i; #"; ($name) = $cd =~ /\bname=([^\s:;]+)/i unless defined $name; ($fname) = $cd =~ /\bfilename="([^"]*)"/i; #"; # filename can be null-str ($fname) = $cd =~ /\bfilename=([^\s:;]+)/i unless defined $fname; $incfn{$name} .= (defined $in{$name} ? "\0" : "") . (defined $fname ? $fname : ""); ($ctype) = $ct =~ /^\s*Content-type:\s*"([^"]+)"/i; #"; ($ctype) = $ct =~ /^\s*Content-Type:\s*([^\s:;]+)/i unless defined $ctype; $inct{$name} .= (defined $in{$name} ? "\0" : "") . $ctype; if ($writefiles && defined $fname) { $ser++; $fn = $writefiles . ".$$.$ser"; open (FILE, ">$fn") || &CgiDie("Couldn't open $fn\n"); binmode (FILE); # write files accurately } substr($buf, 0, $lpos+4) = ''; undef $fname; undef $ctype; } 1; END_MULTIPART if ($errflag) { local ($errmsg, $value); $errmsg = $@ || $errflag; foreach $value (values %insfn) { unlink(split("\0",$value)); } &CgiDie($errmsg); } else { # everything's ok. } } else { &CgiDie("cgi-lib.pl: Unknown Content-type: $ENV{'CONTENT_TYPE'}\n"); } # no-ops to avoid warnings $insfn = $insfn; $incfn = $incfn; $inct = $inct; $^W = $perlwarn; return ($errflag ? undef : scalar(@in)); } # PrintHeader # Returns the magic line which tells WWW that we're an HTML document sub PrintHeader { return "Content-type: text/html\n\n"; } # HtmlTop # Returns the <head> of a document and the beginning of the body # with the title and a body <h1> header as specified by the parameter sub HtmlTop { local ($title) = @_; return <<END_OF_TEXT; <html> <head> <title>$title</title> </head> <body> <h1>$title</h1> END_OF_TEXT } # HtmlBot # Returns the </body>, </html> codes for the bottom of every HTML page sub HtmlBot { return "</body>\n</html>\n"; } # SplitParam # Splits a multi-valued parameter into a list of the constituent parameters sub SplitParam { local ($param) = @_; local (@params) = split ("\0", $param); return (wantarray ? @params : $params[0]); } # MethGet # Return true if this cgi call was using the GET request, false otherwise sub MethGet { return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "GET"); } # MethPost # Return true if this cgi call was using the POST request, false otherwise sub MethPost { return (defined $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq "POST"); } # MyBaseUrl # Returns the base URL to the script (i.e., no extra path or query string) sub MyBaseUrl { local ($ret, $perlwarn); $perlwarn = $^W; $^W = 0; $ret = 'http://' . $ENV{'SERVER_NAME'} . ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') . $ENV{'SCRIPT_NAME'}; $^W = $perlwarn; return $ret; } # MyFullUrl # Returns the full URL to the script (i.e., with extra path or query string) sub MyFullUrl { local ($ret, $perlwarn); $perlwarn = $^W; $^W = 0; $ret = 'http://' . $ENV{'SERVER_NAME'} . ($ENV{'SERVER_PORT'} != 80 ? ":$ENV{'SERVER_PORT'}" : '') . $ENV{'SCRIPT_NAME'} . $ENV{'PATH_INFO'} . (length ($ENV{'QUERY_STRING'}) ? "?$ENV{'QUERY_STRING'}" : ''); $^W = $perlwarn; return $ret; } # MyURL # Returns the base URL to the script (i.e., no extra path or query string) # This is obsolete and will be removed in later versions sub MyURL { return &MyBaseUrl; } # CgiError # Prints out an error message which which containes appropriate headers, # markup, etcetera. # Parameters: # If no parameters, gives a generic error message # Otherwise, the first parameter will be the title and the rest will # be given as different paragraphs of the body sub CgiError { local (@msg) = @_; local ($i,$name); if (!@msg) { $name = &MyFullUrl; @msg = ("Error: script $name encountered fatal error\n"); }; if (!$cgi_lib'headerout) { #') print &PrintHeader; print "<html>\n<head>\n<title>$msg[0]</title>\n</head>\n<body>\n"; } print "<h1>$msg[0]</h1>\n"; foreach $i (1 .. $#msg) { print "<p>$msg[$i]</p>\n"; } $cgi_lib'headerout++; } # CgiDie # Identical to CgiError, but also quits with the passed error message. sub CgiDie { local (@msg) = @_; &CgiError (@msg); die @msg; } # PrintVariables # Nicely formats variables. Three calling options: # A non-null associative array - prints the items in that array # A type-glob - prints the items in the associated assoc array # nothing - defaults to use %in # Typical use: &PrintVariables() sub PrintVariables { local (*in) = @_ if @_ == 1; local (%in) = @_ if @_ > 1; local ($out, $key, $output); $output = "\n<dl compact>\n"; foreach $key (sort keys(%in)) { foreach (split("\0", $in{$key})) { ($out = $_) =~ s/\n/<br>\n/g; $output .= "<dt><b>$key</b>\n <dd>:<i>$out</i>:<br>\n"; } } $output .= "</dl>\n"; return $output; } # PrintEnv # Nicely formats all environment variables and returns HTML string sub PrintEnv { &PrintVariables(*ENV); } # The following lines exist only to avoid warning messages $cgi_lib'writefiles = $cgi_lib'writefiles; $cgi_lib'bufsize = $cgi_lib'bufsize ; $cgi_lib'maxbound = $cgi_lib'maxbound; $cgi_lib'version = $cgi_lib'version; $cgi_lib'filepre = $cgi_lib'filepre; 1; #return true

■mimew.pl
package MIME; # Copyright (C) 1993-94,1997 Noboru Ikuta <noboru@ikuta.ichihara.chiba.jp> # # mimew.pl: MIME encoder library Ver.2.02 (1997/12/30) $main'mimew_version = "2.02"; # インストール : @INC のディレクトリ（通常は /usr/local/lib/perl）にコピー # して下さい。 # # 使用例1 : require 'mimew.pl'; # $from = "From: 生田昇 <noboru\@ikuta.ichihara.chiba.jp>"; # print &mimeencode($from); # # 使用例2 : # UNIXでBase64エンコードする場合 # require 'mimew.pl'; # undef $/; # $body = <>; # print &bodyencode($body); # print &benflush; # # &bodyencode($data,$coding): # データをBase64形式またはQuoted-Printable形式でエンコードする。 # 第2パラメータに"qp"または"b64"を指定することによりコーディング形式 # を指示することができる。第2パラメータを省略するとBase64形式でエン # コードする。 # Base64形式のエンコードの場合は、$foldcol*3/4 バイト単位で変換する # ので、渡されたデータのうち半端な部分はバッファに保存され次に呼ばれ # たときに処理される。最後にバッファに残ったデータは&benflushを呼ぶ # ことにより処理されバッファからクリアされる。 # Quoted-Printable形式のエンコードの場合は、行単位で変換するため、 # データの最後に改行文字が無い場合、最後の改行文字の後ろのデータは # バッファに保存され、次に呼ばれたときに処理される。最後にバッファ # に残ったデータは&benflush("qp")を呼ぶことにより処理されバッファ # からクリアされる。 # # &benflush($coding): # 第1パラメータに"b64"または"qp"を指定することにより、それぞれBase64 # 形式またはQuoted-Printable形式のエンコードを指定することができる。 # 第1パラメータに何も指定しなければBase64形式でエンコードされる。 # Base64のエンコードの場合、&bodyencodeが処理し残したデータを処理し # pad文字を出力する。Quoted-Printableの場合、行単位でなくブロック単 # 位で&bodyencodeを呼ぶ場合、&bodyencodeが処理し残したデータがもし # バッファに残っていればそれを処理する。 # 一つのデータを(1回または何回かに分けて)&bodyencodeした後に必ず1回 # 呼ぶ必要がある。 # # &mimeencode($text): # 第1パラメータが日本語文字列を含んでいれば、その部分をISO-2022-JPに # 変換したあと、MIME encoded-word(RFC2047参照)に変換する。必要に応じ # てencoded-wordの分割とencoded-wordの前後での行分割を行う。 # # 文字コードの自動判定は、同一行にShiftJISとEUCが混在している場合を # 除いて漢字コードの混在にも対応している。ShiftJISかEUCかどうしても # 判断できないときは$often_use_kanjiに設定されているコードと判定する。 # ISO-2022-JPのエスケープシーケンスは$jis_inと$jis_outに設定すること # により変更可能である。 $often_use_kanji = 'EUC'; # or 'SJIS' $jis_in = "\x1b\$B"; # ESC-$-B ( or ESC-$-@ ) $jis_out = "\x1b\(B"; # ESC-(-B ( or ESC-(-J ) # 配布条件 : 著作権は放棄しませんが、配布・改変は自由とします。改変して # 配布する場合は、オリジナルと異なることを明記し、オリジナル # のバージョンナンバーに改変版バージョンナンバーを付加した形 # 例えば Ver.2.02-XXXXX のようなバージョンナンバーを付けて下 # さい。なお、Copyright表示は変更しないでください。 # # 注意 : &mimeencodeをjperl1.X(の2バイト文字対応モード)で使用すると、SJIS # とEUCをうまく7bit JIS(ISO-2022-JP)に変換できません。 # 入力に含まれる文字が7bit JIS(ISO-2022-JP)とASCIIのみであること # が保証されている場合を除き、必ずoriginalの英語版のperl（または # jperl1.4以上を -Llatin オプション付き）で動かしてください。 # なお、Perl5対応のjperlは試したことがないのでどのような動作になる # かわかりません。 # # 参照 : RFC1468, RFC2045, RFC2047 ## MIME base64 アルファベットテーブル（RFC2045より） %mime = ( "000000", "A", "000001", "B", "000010", "C", "000011", "D", "000100", "E", "000101", "F", "000110", "G", "000111", "H", "001000", "I", "001001", "J", "001010", "K", "001011", "L", "001100", "M", "001101", "N", "001110", "O", "001111", "P", "010000", "Q", "010001", "R", "010010", "S", "010011", "T", "010100", "U", "010101", "V", "010110", "W", "010111", "X", "011000", "Y", "011001", "Z", "011010", "a", "011011", "b", "011100", "c", "011101", "d", "011110", "e", "011111", "f", "100000", "g", "100001", "h", "100010", "i", "100011", "j", "100100", "k", "100101", "l", "100110", "m", "100111", "n", "101000", "o", "101001", "p", "101010", "q", "101011", "r", "101100", "s", "101101", "t", "101110", "u", "101111", "v", "110000", "w", "110001", "x", "110010", "y", "110011", "z", "110100", "0", "110101", "1", "110110", "2", "110111", "3", "111000", "4", "111001", "5", "111010", "6", "111011", "7", "111100", "8", "111101", "9", "111110", "+", "111111", "/", ); ## JISコード(byte数)→encoded-word の文字数対応 %mimelen = ( 8,30, 10,34, 12,34, 14,38, 16,42, 18,42, 20,46, 22,50, 24,50, 26,54, 28,58, 30,58, 32,62, 34,66, 36,66, 38,70, 40,74, 42,74, ); ## ヘッダエンコード時の行の長さの制限 $limit=74; ## ＊注意＊ $limitを75より大きい数字に設定してはいけない。 ## ボディbase64エンコード時の行の長さの制限 $foldcol=72; ## ＊注意＊ $foldcolは76以下の4の倍数に設定すること。 ## ボディQuoted-Printableエンコード時の行の長さの制限 $qfoldcol=75; ## ＊注意＊ $foldcolは76以下に設定すること。 ## null bitの挿入と pad文字の挿入のためのテーブル @zero = ( "", "00000", "0000", "000", "00", "0" ); @pad = ( "", "===", "==", "=" ); ## ASCII, 7bit JIS, Shift-JIS 及び EUC の各々にマッチするパターン $match_ascii = '\x1b\([BHJ]([\t\x20-\x7e]*)'; $match_jis = '\x1b\$[@B](([\x21-\x7e]{2})*)'; $match_sjis = '([\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc])+'; $match_euc = '([\xa1-\xfe]{2})+'; ## MIME Part 2(charset=`ISO-2022-JP',encoding=`B') の head と tail $mime_head = '=?ISO-2022-JP?B?'; $mime_tail = '?='; ## &bodyencode が使う処理残しデータ用バッファ $benbuf = ""; ## &bodyencode の処理単位（バイト） $bensize = int($foldcol/4)*3; ## &mimeencode interface ## sub main'mimeencode { local($_) = @_; s/$match_jis/$jis_in$1/go; s/$match_ascii/$jis_out$1/go; $kanji = &checkkanji; s/$match_sjis/&s2j($&)/geo if ($kanji eq 'SJIS'); s/$match_euc/&e2j($&)/geo if ($kanji eq 'EUC'); s/(\x1b[\$\(][BHJ@])+/$1/g; 1 while s/(\x1b\$[B@][\x21-\x7e]+)\x1b\$[B@]/$1/; 1 while s/$match_jis/&mimeencode($&,$`,$')/eo; s/$match_ascii/$1/go; $_; } ## &bodyencode interface ## sub main'bodyencode { local($_,$coding) = @_; if (!defined($coding) || $coding eq "" || $coding eq "b64"){ $_ = $benbuf . $_; local($cut) = int((length)/$bensize)*$bensize; $benbuf = substr($_, $cut+$[); $_ = substr($_, $[, $cut); $_ = &base64encode($_); s/.{$foldcol}/$&\n/g; }elsif ($coding eq "qp"){ # $benbuf が空でなければデータの最初に追加する $_ = $benbuf . $_; # 改行文字を正規化する s/\r\n/\n/g; s/\r/\n/g; # データを行単位に分割する(最後の改行文字以降を $benbuf に保存する) @line = split(/\n/,$_,-1); $benbuf = pop(@line); local($result) = ""; foreach (@line){ $_ = &qpencode($_); $result .= $_ . "\n"; } $_ = $result; } $_; } ## &benflush interface ## sub main'benflush { local($coding) = @_; local($ret) = ""; if ((!defined($coding) || $coding eq "" || $coding eq "b64") && $benbuf ne ""){ $ret = &base64encode($benbuf) . "\n"; $benbuf = ""; }elsif ($coding eq "qp" && $benbuf ne ""){ $ret = &qpencode($benbuf) . "\n"; $benbuf = ""; } $ret; } ## MIME ヘッダエンコーディング sub mimeencode { local($_, $befor, $after) = @_; local($back, $forw, $blen, $len, $flen, $str); $befor = substr($befor, rindex($befor, "\n")+1); $after = substr($after, 0, index($after, "\n")-$[); $back = " " unless ($befor eq "" || $befor =~ /[ \t$]$/); $forw = " " unless ($after =~ /^\x1b\([BHJ]$/ || $after =~ /^\x1b\([BHJ][ \t$]/); $blen = length($befor); $flen = length($forw)+length($&)-3 if ($after =~ /^$match_ascii/o); $len = length($_); return "" if ($len <= 3); if ($len > 39 || $blen + $mimelen{$len+3} > $limit){ if ($limit-$blen < 30){ $len = 0; }else{ $len = int(($limit-$blen-26)/4)*2+3; } if ($len >= 5){ $str = substr($_, 0, $len).$jis_out; $str = &base64encode($str); $str = $mime_head.$str.$mime_tail; $back.$str."\n ".$jis_in.substr($_, $len); }else{ "\n ".$_; } }else{ $_ .= $jis_out; $_ = &base64encode($_); $_ = $back.$mime_head.$_.$mime_tail; if ($blen + (length) + $flen > $limit){ $_."\n "; }else{ $_.$forw; } } } ## MIME base64 エンコーディング sub base64encode { local($_) = @_; $_ = unpack("B".((length)<<3), $_); $_ .= $zero[(length)%6]; s/.{6}/$mime{$&}/go; $_.$pad[(length)%4]; } ## Quoted-Printable エンコーディング sub qpencode { local($_) = @_; # `=' 文字を16進表現に変換する s/=/=3D/g; # 行末のタブとスペースを16進表現に変換する s/\t$/=09/; s/ $/=20/; # 印字可能文字(`!'～`~')以外の文字を16進表現に変換する s/([^!-~ \t])/&qphex($1)/ge; # 1行が$qfoldcol文字以下になるようにソフト改行をいれる local($folded, $line) = ""; while (length($_) > $qfoldcol){ $line = substr($_, 0, $qfoldcol-1); if ($line =~ /=$/){ $line = substr($_, 0, $qfoldcol-2); $_ = substr($_, $qfoldcol-2); }elsif ($line =~ /=[0-9A-Fa-f]$/){ $line = substr($_, 0, $qfoldcol-3); $_ = substr($_, $qfoldcol-3); }else{ $_ = substr($_, $qfoldcol-1); } $folded .= $line . "=\n"; } $folded . $_; } sub qphex { local($_) = @_; $_ = '=' . unpack("H2", $_); tr/a-f/A-F/; $_; } ## Shift-JIS と EUC のどちらの漢字コードが含まれるかをチェック sub checkkanji { local($sjis,$euc); $sjis += length($&) while(/$match_sjis/go); $euc += length($&) while(/$match_euc/go); return 'NONE' if ($sjis == 0 && $euc == 0); return 'SJIS' if ($sjis > $euc); return 'EUC' if ($sjis < $euc); $often_use_kanji; } ## EUC を 7bit JIS に変換 sub e2j { local($_) = @_; tr/\xa1-\xfe/\x21-\x7e/; $jis_in.$_.$jis_out; } ## Shift-JIS を 7bit JIS に変換 sub s2j { local($string); local(@ch) = split(//, $_[0]); while(($j1,$j2)=unpack("CC",shift(@ch).shift(@ch))){ if ($j2 > 0x9e){ $j1 = (($j1>0x9f ? $j1-0xb1 : $j1-0x71)<<1)+2; $j2 -= 0x7e; } else{ $j1 = (($j1>0x9f ? $j1-0xb1 : $j1-0x71)<<1)+1; $j2 -= ($j2>0x7e ? 0x20 : 0x1f); } $string .= pack("CC", $j1, $j2); } $jis_in.$string.$jis_out; } 1;