ホーム ＞ HTMLに役立つヒント ＞perlのいろんなルーチン入れ

perlのいろんなルーチン入れ

　自分でperlを書いていて、しょっちゅう使いそうなもの、作るのに苦労したルーチン、引っかかったことなどを書きためている。ま、自分用の備忘録です。使う場合はオウンリスクでどうぞ。何せ初心者ですから間違いがあるかも。

■■　目次　■■

mac/unix　 ロックファイルでロックする　 文字列中の改行を<br>に変換　 変数に何かの処理をして戻す/サブルーチンの基礎　 他のファイルに飛ばす　 CGIを呼び出すファイル/ディレクトリの制限　 ファイルの読み込みと書き出し　 emailアドレスとパスワードのチェック　 ファイル拡張子のチェック　 form入力を捕まえる　 変数を分解して値を取り出す　 jcode.plの使い方　付録：perlはEUCで書こうリンク Jcode.pmのインストール　 Encode.pm覚え書き　 Net::FTPの覚え書き　 レスポンスヘッダを確認する　 サブルーチンの引数　 .plとHTMLのやりとり　 メールアドレスをエンティティ化　 CGIエラーのトラップ　 タイムアウト処理　 パスから名前を取り出す

ソートに関するメモ 自分のいるパスを知る　 文字列に特定の文字があるか調べる/部分取りだし　 HTMLをそのまま出力する　 エンコードでヘッダを書き分ける　 四捨五入　 カンマで位取り　 スクリプトの処理時間を計る　 日付と時間を出力する　 ファイルの更新日を取得する　 ディレクトリにあるファイル数を取得する　 NET::SMTPでメール送信　 テストルーチン　 配列@の要素の数を調べる　 配列からまんべんなく重複せずにランダムに取り出す パッチ　 掲示板のスパム対策　 ()の閉じ忘れがないかチェック for SQL　 フォルダドロップ対応ドロップレット　MacPerl用 UVJ Mailerでメール送信機能をつける　MacPerl用 深いディレクトリを作る　MacPerl/unix perl用 MacPerlのTips　MacPerl用 リンク

mac/UNIX　▲ページトップ　▲▲HTMLに役立つヒント

●MACとUNIXの違いでよく使うルーチン

# OSがUNIXなら0、macなら1。
$pc = "0";

# mac/UNIXの区切りをセット
if ( $pc == 1) { # 1はマック
	$partition = ":"; # home:name:等の区切り
	$partition_down = ":"; # 相対パスで下がる時
	$partition_up = "::"; # 相対パスであがる時
} else { # その他はUNIX
	$partition = "/"; # /home/name/等の区切り
	$partition_down = "./"; # 相対パスでおりる時
	$partition_up = "../"; # 相対パスであがる時
}

上のように：をセットするのは煩雑なので、通常はUNIXのパスにしておいて、MacPerlの時だけ次のルーチンをくぐらせる。ファイルの読み込み/書き出しルーチンに「if ($pc eq "1"){$aaa = &mac_dir($aaa); }」のようにセットしておくといいだろう。

# UNIXのパスをMacのパスに変換 for MacPerl
# if ($pc eq "1"){$aaa = &mac_dir(ディレクトリ); }のように呼び出す
# パスだけに使う方が無難。URLには使わないこと。
# 5つ上の階層までしかサポートしていないが、通常はこれで十分と思われる。
sub mac_dir {
	my $mydir = $_[0];
	$mydir =~ s/^\.\.\/\.\.\/\.\.\/\.\.\/\.\.\//::::::/g ; # 行頭の../../../../を::::::　5つ上
	$mydir =~ s/^\.\.\/\.\.\/\.\.\/\.\.\//:::::/g ; # 行頭の../../../を:::::　4つ上
	$mydir =~ s/^\.\.\/\.\.\/\.\.\//::::/g ; # 行頭の../../を::::　3つ上
	$mydir =~ s/^\.\.\/\.\.\//:::/g ; # 行頭の../../を:::　2つ上
	$mydir =~ s/^\.\.\//::/g ; # 行頭の../を::　一つ上
	$mydir =~ s/^\.\//:/g ; # 行頭の./を:に

	$mydir =~ s/\//:/g ; # /をすべて:に

	return $mydir ; # 返す
}

# 上と同じ。こちらは階層がいくつあっても大丈夫
sub mac_dir {
	my $mydir = $_[0];
	$mydir =~ s/^\.\//:/g ; # 行頭の./を:に
	$mydir =~ s/^\.\.\//::/ ; # 行頭の../を::に
	$mydir =~ s/\.\.\//:/g ; # すべての../を:に
	$mydir =~ s/\//:/g ; # /をすべて:に
	if($mydir !~ m/^:/){ # 頭に:がなければ
		$mydir = ":"."$mydir"; # 頭に:をつける。この方が確実
	}
	return $mydir;
}

●MacPerlで\rや\nとやると、UNIXperlと逆に\rでLF、\nでCRとして扱われてしまう。どちらでも動くスクリプトを書くときに、改行コードが重要な場合は\rや\nではなく、$cr、$lfを使ったりする。

$cr = "\x0D";
$lf = "\x0A";

　とやっておいて、後は\r/\nではなく、$cr/$lfを使って記述していく。

●最近はMacPerlで開発してOS Xに持っていくことが多いので、こんなふうに自動判定させている。

# Classic MacかOS Xか自動判定
$cr = "\x0D";
$lf = "\x0A";
if ("\n" eq $cr){ # MacPerl
	$pc = '1';
}else { # OS X
	$pc = '0';
}

●MacPerlの時間とUNIX perlの時間

「$times = time();」とすると、$timesには現在時間の秒数が入ります。

　ところが、MacPerlとUNIX perlでは時間のカウントが異なります。これは、旧Mac OSが1904年1月1日0時0分0秒を起点として時間を数えるのに対し、UNIXマシン（OS Xも）では1970年1月1日0時0分0秒からの秒数だからです。その差は2082877200秒になります。

　MacPerl/UNIX perl両用のスクリプトを書く時、この点を考慮して、保存データなどに秒数を書き込むときには、UNIX時間にデータを統一しておいた方がいいでしょう。

$pc = "0";# OSがUNIXなら0、macなら1。

# MacPerlで秒数を取得したなら、それをUNIX時間に変更してデータファイルに書き込む。
# $timesにMACの秒数が入っているとすると、
if($pc == "1"){ # MacPerlなら
	$times = $times - 2082877200 ; # UNIX時間に
}
　このようにしてからデータファイルに書き込む。

# 反対にデータファイルからUNIX秒数を読み込む時、Mac時間にした後処理します。
# $timesにUNIXの秒数が入っているとすると、
if($pc == "1"){ # MacPerlなら
	$times = $times + 2082877200 ; # Mac時間に
}

ロックファイルでロックする　▲ページトップ　▲▲HTMLに役立つヒント

●ロックファイルを作ってロックするという手口は、掲示板CGIなどでよく利用されている。確実なんでしょうね、きっと。
　ファイル書き込み部分を&lock;と&unlock;で挟む。シンボリックリンクでロックファイルを作ってます。すでにファイルが存在していると失敗して偽を返しますのでちょっとsleepしてまたトライします。6回トライしてもまだ失敗するときはエラー処理に飛ばしてます。
　でも、このルーチン、マックで試してないや。

$locfileはこれより前で指定しておく。「$locfile = "なんとかかんとか.lock" ;」なんて感じ。

sub lock {
	local($busy) = 6;
	while (!symlink(".",$lockfile)) {
		if (--$busy <= 0) {
			$error = "BUSY!　後ほどおためしください。"; 
			&error ;
		}
		sleep(5);
	}
}

sub unlock {
	unlink($lockfile);
}

　カレントディレクトリではなく、違うディレクトリのファイルをロックしたい場合は「$locfile = "../なんとかかんとか.lock" ;」なんて具合にする。

　排他制御についてはこんなところを見つけた。open、symlink、mkdir、flockなどなど、すごく丁寧で細かい解説が嬉しい。MACperlの話も詳しいです。「Web& Mail&Mac講座」

●cgi自体をロックして閉め出す場合はこんなルーチンも

$cginame = "cyousa.cgi"; # このcgiの名前

# $cginameをロック
if ( $pc == 0) { chmod 0644 , "$cginame" ; }

# $cginameをロック解除
if ( $pc == 0) { chmod 0755 , "$cginame" ; }

●cgiのロック解除を忘れないためには、exit用のサブルーチンを作り、必ず処理を中断する時にこのルーチンを「& exit_sub」のように呼び出すようにすると良い。

sub exit_sub {
# $cginameをロック解除
	if ( $pc == 0) { chmod 0755 , "$cginame" ; }
	exit;
}

文字列$aaaの中の改行を<br>に変換する　▲ページトップ　▲▲HTMLに役立つヒント

$aaa =~ s/(\r\n|\n|\r)/<br>/g ;

$aaa =~ s/(\n\r|\r\n|\n|\r)/<br>/g ; # MacPerlの場合は\nと\rが入れ替わるのでこうした方がいいだろう。

　雛形htmlを用意して置いて、それを読み込んで、埋め込み変数部分を変数のあいたに置き換える手法はよく使う。その時のちょっとしたメモ。

for(my $y=1;$y<=10;$y++){
	$thispatt = $barpar[$y]; # 一度変数にセットして
	$fullhtml =~ s/\#\#imagebar$y\#\#/$thispatt/g; # 変換する
	# []が文字クラスと見なされ　$fullhtml =~ s/\#\#imagebar$y\#\#/$barpar[$y]/g;　は失敗する。
}

変数に何かの処理をして戻す/サブルーチンの基礎　▲ページトップ　▲▲HTMLに役立つヒント

　ここではクロスサイトスクリプティングを無力化（サニタイジング）するためのルーチン（特殊文字を無害な形に変換して戻す）を例に示します。

# クロスサイトスクリプティング対策に
# 特殊文字を無力化する（サニタイジング）
# $aaa = &xss("サニタイジングしたい文字列");　で呼び出す
sub xss {
	#文字列は$_[0]で受ける。
	$_[0] =~ s/&/&/g; # &
	$_[0] =~ s/\"/"/g; #"
	$_[0] =~ s/\'/'/g; # '
	$_[0] =~ s/</&lt;/g; # <
	$_[0] =~ s/>/&gt;/g; # >
	return $_[0]; # 結果を送り返す
}

# 上と反対。変換した特殊文字を元に戻す
sub dexss {
	#$aaa = &dexss("$aaa");などとして呼び出し
	#文字列は$_[0]で受ける
		$_[0] =~ s/&amp;/&/g;
		$_[0] =~ s/&quot;/\"/g;
		$_[0] =~ s/&#39;/\'/g;
		$_[0] =~ s/&lt;/</g;
		$_[0] =~ s/&gt;/>/g;
	return $_[0];
}

　サニタイジングの話がでたところで関連ページ。

「Webサイトにおけるクロスサイトスクリプティング脆弱性に関する情報」IPAのページ。
「IPA ISEC　セキュア・プログラミング講座」IPAのページ。

ファイルに飛ばす　▲ページトップ　▲▲HTMLに役立つヒント

print "Location: $filename\n\n";

　これだけ。

CGIを呼び出すファイル/ディレクトリの制限　▲ページトップ　▲▲HTMLに役立つヒント

　CGIを呼び出すHTMLファイルを偽装される場合があります。そこで、CGIを呼び出したHTMLが確かに特定のサーバのファイル/ディレクトリから呼び出されたものかチェックしてやります。

# ========================
# ファイルによる限定の場合
$okfile= 'http://www.aaa.bbb.co.jp/ccc.html'; # 呼び出しを許可するファイル名
&from_check_f;

sub from_check_f {
 if($ENV{HTTP_REFERER} ne $okfile){
 &error('不正なCGI呼び出しです。'); 
 exit;
 }
}

# ========================
# ディレクトリによる限定の場合
$okdir= 'http://www.aaa.bbb.co.jp/'; # 呼び出しを許可するディレクトリ名
&from_check_d;

sub from_check_d {
 local $formdir = $ENV{HTTP_REFERER};
 local $flg = ( $formdir =~ m/^$okdir/) ;
 if($flg != 1){
 &error('不正なCGI呼び出しです。'); 
 exit;
 }
}

# =========================
#　呼び出し元のチェック
$ref_url = 'http://www.aaa.bbb.co.jp/test/index.html'; # 呼び出しを許可するファイルのURL
$cgi_url = 'http://www.aaa.bbb.co.jp/cgi-bin/test.cgi'; # CGIのURL

if($ENV{HTTP_REFERER} !~ m/^$ref_url/){ # 呼び出し元ページじゃない
	if($ENV{HTTP_REFERER} !~ m/^$cgi_url/){ # 自分自身からの呼び出しじゃない
		$error = "不正な呼び出しです。";
	}
}
# 念のためPOST限定
if( $ENV{'REQUEST_METHOD'} eq "GET" ) {
	$error = "不正な呼び出しです。";
}

ファイルの読み込みと書き出し　▲ページトップ　▲▲HTMLに役立つヒント

# ===================================
# ファイルを読み込んで返すルーチン　その1
# $aaa = &read_file(ファイル名); のように呼び出す。
sub read_file {
	my $socefile = $_[0]; # ファイル名の受け取り
	# ファイルのオープン
	open (RSS,"<$socefile")|| die "ファイル「$socefile」が開けません";
	#ファイルの読み込み
	my $allfile = ""; # 初期化
	while ($_ = <RSS>){
		$allfile .= $_; # 最後まで読む
	}
	#ファイルのクローズ
	close (RSS) ;
	return $allfile ; # 送り返す
}

# ===================================
# ファイルを読み込んで返すルーチン　その2
# ファイルが存在するかチェックしてから読み込む。存在しない場合は別の内容を返す。
# $aaa = &read_file(ファイル名); のように呼び出す。
sub read_file {
	my $socefile = $_[0]; # ファイル名の受け取り
	my $allfile = ""; # 初期化
	if (-e $socefile){ # ファイルがあったら
		# ファイルのオープン
		open (RSS,"<$socefile")|| die "ファイル「$socefile」が開けません";
		#ファイルの読み込み
		while ($_ = <RSS>){
			$allfile .= $_; # 最後まで読む
		}
		#ファイルのクローズ
		close (RSS) ;
	} else { # ファイルがなければ
		$allfile = "" ; # 必要に応じてエラーなどを入れる
	}
	return $allfile ; # 送り返す
}

# ===================================
# ファイルの書き出し
# &write_file(ファイル名,内容,モード); のように呼び出す。
# モードは0で上書き、1で追記
sub write_file {
	my $filename = $_[0];
	my $content = @_[1];
	my $mode = @_[2];
	# 書き込みファイルのオープン
	if ($mode eq "0") { # 上書き
		open (FILE,">$filename")|| die "ファイル「$filename」に出力できません";
	} else {
		if ($mode eq "1") { # 追記
			open (FILE,">>$filename")|| die "ファイル「$filename」に出力できません";
		}
	}
	print (FILE "$content") ; # ファイルに出力
	#ファイルのクローズ
	close (FILE) ;
}

　おまけ。ファイルバックアップを作るルーチン。前後に排他制御を忘れずに。

# ===================================
# ファイルのバックアップ
# &backup_file(ファイル名); のように呼び出す。
sub backup_file {
	my $filename = $_[0];
	# ファイルの読み込み
	open (RFILE,"<$filename")|| die "ファイル「$filename」が開けません";
	my $allfile = ""; # 初期化
	while ($_ = <RFILE>){
		$allfile .= $_; # 最後まで読む
	}
	close (RFILE) ;
	# ファイルの書き出し。　ファイル名の最後には「.bak」を追加。
	open (WFILE,">$filename.bak")|| die "ファイル「$filename.bak」に出力できません";
	print (WFILE "$allfile") ; # ファイルに出力
	#ファイルのクローズ
	close (WFILE) ;
}

emailアドレスとパスワードのチェックルーチン　▲ページトップ　▲▲HTMLに役立つヒント

# emailアドレスのチェックルーチン
# &email_check("調べたいアドレス") ; のように呼び出す
sub email_check { 
	my $address = $_[0]; # 調べるアドレスの受け取り
	my $email_error = ""; # 初期化
	# ↓$addressの中を調べて英文字と数字、@、ピリオド以外のものがあると
	# ↓$email_errorに1が入る。
	$email_error = ( $address =~ /[^a-zA-Z0-9€_€@€.]/ ) ; # !~なら[a-zA-Z0-9€_€@€.]とする
	#↓$addressの中を調べて@がない/2つ以上あるとエラー
	local($position,$status);
	$position = 0; # 初期化
	$status = 0 ; # 初期化 これが1以外はエラー
	while ( ($position = index($address , "@" , $position)) > 0 ){
		$status ++;
		$position ++;
	}
	if ($status != 1){ # 1でなければ
		$email_error = 1 ; # エラーステータスを立てる
	}
	# エラー判定
	if ($email_error ne ""){
		print "emailに入力エラーがあります。" ; # 必要に応じてエラーに飛ばす。
	}
}

もうちょっと厳密なアドレス判定

# メールアドレスのチェック==============================
sub email_check { 
	local($error_flg) = ""; # 初期化
	local($allmail) = $_[0] ; # 初期化
	#↓$_[0]全体を調べて@がない/2つ以上あるとエラー
	# $positionは@の位置、$statusは@の数
	local($position,$status) = 0;
	while ( ($position = index($allmail , "@" , $position)) > 0 ){
		$status ++;
		$position ++;
	}
	if ($status != 1){ # 1でなければ
		$error .= "メールアドレスにエラーがあります。<br>\n";
	} else { # @がひとつなら
		@domain = split(/@/,$allmail); # @で分解
		# 前半部のチェック
		# ↓中を調べて英文字と数字、_、ピリオド、-以外のものがあると
		# ↓$error_flgに1が入る。
		$error_flg = ( @domain[0] =~ /[^a-zA-Z0-9\_\.\-]/ ) ; # これ以外は入力できない
			if ($error_flg == 1) {$error_flg2 = 1;} # エラーを取っておく
		# ドメインのチェック
		# ↓中を調べて英文字と数字、ピリオド、-以外のものがあると
		# ↓$error_flgに1が入る。
		$error_flg = ( @domain[1] =~ /[^a-zA-Z0-9\.\-]/ ) ; # これ以外は入力できない
			if ($error_flg == 1) {$error_flg2 = 1;} # エラーを取っておく
		if ($error_flg2 == 1) { # 前半・ドメインのどちらかでエラー
			$error .= "メールアドレスは半角英数字で入力してください。<br>\n";
		}
	}
}

　とほほさんがWwwMailでお使いになった方法。あっさりしてますね。さすがです。

			if ($email !~ /^[-_\.a-zA-Z0-9]+\@[-_\.a-zA-Z0-9]+$/) {
				$error .= "メールアドレスが不正です。<br>\n";
			}

　パスワードのチェックはこんな感じ。

# パスワードのチェックルーチン
# $passwd1と$passwd2を比べて入力間違いをチェックする場合。
# ここでは大小英文字と英数字、ピリオド、カンマ、アンダースコアしか許していない。
# 6文字以上ないとエラーとなる。
# &passwd_check("パスワード1","パスワード2") ; のように呼び出す。
sub passwd_check { 
	my $passwd1 = $_[0];
	my $passwd2 = $_[1];
	my $passwd_error = ""; # 初期化
	# ↓$passwd1と2を比べて、違っていたらエラー3
	if ($passwd1 ne $passwd2) { $passwd_error = "3";}
	# ↓$passwd1の中を調べている。英文字と英数字、.,_しか許していない。エラーだと1になる
	$passwd_error = ( $passwd1 !~ /[a-zA-Z0-9\.\,_]/ ) ;
	# ↓$passwd1の長さを調べている。エラーは2
	$char_length = length $passwd1 ;
	if ( $char_length < 6 ) { $passwd_error = "2" } ;
	if ($passwd_error ne "") {
		print "パスワードがエラーです"; # 必要に応じてエラーに飛ばしたり、上のエラーコードで理由を書いたり。
	}
}

ファイル拡張子のチェック　▲ページトップ　▲▲HTMLに役立つヒント

#テスト用スクリプト
# 許可する拡張子を半角スペースで区切る。「.」を忘れずに。
$suffix = ".jpg .jpeg .gif .png .html .htm .shtml"; 
&suffix_check("aaa.html");
print "okさ\n";
exit;


# ●許可されている拡張子かチェック===================
# &suffix_check("チェックしたいファイル名");　のように呼び出す
sub suffix_check {
	my $filename = $_[0];
	my $flag = "";
	foreach $tmp (split(/ +/, $suffix)) {# サフィックスを分解する
		$tmp =~ s/\./\\./g ;
		if( $filename =~ m/$tmp$/) {$flag = "1";} # 合致したらフラグをたてる
	}
	if ($flag ne "1") { # 拡張子がなかったら
		my $error = "「$suffix」以外の拡張子です。ファイル名は「$filename」です。";
		print "$error";
		exit;
	}
}

　もっと簡略化すると、こんな風になる。判定は簡略になりますが、$suffixの設定は慣れてないと無理かな。要は$suffixの設定を正規表現で書くだけなんですが。

$suffix = "\.html|\.htm|\.shtml|\.shtm"; # 処理対象の拡張子を|区切りで。.は\.と記述

if( $filename =~ m/($suffix)$/){
	print "ファイルの処理をここに書く\n";
} else {
	print "処理対象じゃない\n";
}

変数を分解して値を取り出す　▲ページトップ　▲▲HTMLに役立つヒント

# テスト用の変数
	$get_txt = "q1q2q3q4q5q6q7q8q9";
	
	# メインルーチン
	@get_parts = split( /q/, $get_txt ); # 内容をqを目印にパーツに分ける
	
	print "Content-type: text/html\n\n";
	print "<HTML>\n";
	print "<HEAD>\n";
	print "<TITLE>変数の中身をパーツに分ける</TITLE>\n";
	print "</HEAD>\n";
	print "<BODY>\n";

	# 取り出し方1
	$num = 0;
	print "==============================<br>\n";
	foreach $key_val_line ( @get_parts ) { # パーツごとに名前と値を取り出す
		print "$num = $key_val_line<br>\n" ; # 行毎に表示
	$num++;
	}
	
	# 取り出し方2
	$num = 0;
	print "==============================<br>\n";
	while ($num <= 9) {
		print "$num = @get_parts[$num]<br>\n" ; # ダイレクトに表示
	$num++;
	}
	
	print "</BODY>\n";
	print "</HTML>\n";
	exit;

form入力を捕まえる　▲ページトップ　▲▲HTMLに役立つヒント

# formからの入力をつかまえるルーチン
# 下のHTMLからこのcgiを呼び出す場合、この.cgiは「input.cgi」という名前にする。
# cgi-lib.plをrequireして「&ReadParse(*in);」すれば簡単なんですけどね。
# 取り出しのためだけにcgi-lib.plをおくのがもったいなくて。

require 'jcode.pl'; # cgiの最初の方に書いておくこと
$lang = "euc"; # 出力するコード

print "Content-type: text/html\n\n";
	print "<HTML><TITLE>入力したのは</TITLE>";
	print "<body bgcolor=\"#ffffff\">";

		&input_get ; # ゲットルーチンの呼び出し
		print "<br>cgi-lib.plと同じように\$in{'変数名'}でとりだす。変数txtの中身は：$in{'txt'}<br>\n";

print "</body></HTML>\n";
exit ;

# ===================================
# formを受けとった後、変数を取り出すルーチン。
# &input_get; のように1度呼び出す。
# このルーチンを通った後は、$in{'変数名'}で取り出せる。
sub input_get { 
	local ($get_txt , @get_parts , $line , $key , $val ) ; #  $in{$key}はグローバル変数
	if( $ENV{'REQUEST_METHOD'} eq "POST" ) {
		read ( STDIN, $get_txt, $ENV{'CONTENT_LENGTH'} ); # postだったらバイト数を得る
	} else {
		$get_txt = $ENV{'QUERY_STRING'}; # getだったらストリングを得る
	}
	$get_txt =~ s/\+/ /g; # 半角スペースを変換
	@get_parts = split( /&/, $get_txt ); # 内容を&を目印にパーツに分ける
	foreach $key_val_line ( @get_parts ) { # パーツごとに名前と値を取り出す
		($key, $val) = split(/=/,$key_val_line,2); # splits on the first =.　以下、cgi-lib.plからもらった
		# 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; #
		&jcode'convert( *key, $lang ); # $langに合わせて漢字コードを変換
		&jcode'convert( *val, $lang ); # $langはeuc/sjis/jisの指定ができる
		$in{$key} = $val; # 変数に格納。$in{'変数名'}で取り出せる
	}
}

　---------------　お試し用HTML例　-------------------------
<HTML> 
<HEAD>
 <META HTTP-EQUIV="Content-Type" CONTENT="text/html;CHARSET=x-sjis">
 <TITLE>Untitled Document</TITLE>
</HEAD>
<BODY BGCOLOR="#ffffff">
	<!-- 上のcgiと併せて試すと動きがわかりやすいっす -->
	<P>
	こちらはpost。普通はこっち。<BR>
	<FORM ACTION="input.cgi" METHOD="POST">
		なんか入力してみて<INPUT NAME="txt" TYPE="text" SIZE="40"><BR>
		なんか選んで　<INPUT TYPE="checkbox" NAME="pass" VALUE="1">パスワードも送る</P>
		
		<P><INPUT NAME="mode" TYPE="submit" VALUE="送信">
		　<INPUT NAME="mode" TYPE="submit" VALUE="確認">
	</FORM>
	<hr>
	こちらはget<BR>
	<FORM ACTION="input.cgi" ENCTYPE="text/plane" METHOD="get">
		なんか入力してみて<INPUT NAME="txt" TYPE="text" SIZE="40"><BR>
		なんか選んで　<INPUT TYPE="checkbox" NAME="pass" VALUE="1">パスワードも送る</P>
		
		<P><INPUT NAME="mode" TYPE="submit" VALUE="送信">
		　<INPUT NAME="mode" TYPE="submit" VALUE="確認">
	</FORM>
</BODY>
</HTML>

※マルチパート（multipart/form-data）形式のformの場合、上の方法では取り出せません。面倒だったので、僕の場合、マルチパートだったらあっさりCGI.pmを使うことに。振り分けはこんな感じ。CGI.pmの使い方はgoogleあたりで探してください。

if ($ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/i) { # マルチパートの場合
	# あっさりCGI.pmを使うことに(^_^;
	# テキトーにuse CGI ;を使ったルーチンに仕立てる
} else {
	# ここに上の「input_get」ルーチンを記述
}

jcode.plの使い方　▲ページトップ　▲▲HTMLに役立つヒント

　Kazumasa Utashiroさんの作成されたjcode.plは広く使われています。Kazumasa Utashiroさんに大感謝！　オフィシャルページはこちら。

　まずはモジュールを宣言する。同じ階層に置く場合は「require './jcode.pl';」とする。

# ●モジュールの宣言
require 'jcode.pl';

●半角カナを全角に　&jcode'h2z_euc(*変数名) ; # eucのところは環境に合わせてSJIS、jisなどとする。
●漢字コード変換　&jcode'convert (*変数名,euc) ; # eucのところは環境に合わせてSJIS、jisなどとする。
●全角英数字を半角英数字に　&jcode'tr(*変数名, '０-９Ａ-Ｚａ-ｚ−', '0-9A-Za-z-');

　「*変数名」のところは、変数が$aaaだとすると、「*aaa」と記述する。

　「ミケネコ研究所」に「jcode.plの私的な解説書」があります。

●付録
　perlで日本語を処理するためには、EUCでスクリプトを書くのがラクチン。SJISで書くと、パターンマッチで問題が出るから。とゆーリンクです。「perl　EUC SJIS　パターンマッチ　検索」あたりで検索すると他にもいっぱいでてくると思います。
　・Shift_JISテキストを正しく扱う
　・Perlでユニコードを処理する
　・Perlメモ

●付録2
　パターンマッチの話なんだが、ここにメモしておく。半角カナの範囲をEUCコードで表現すると「\x8E[\xA0-\xDF]」となるのは有名。全角カナ以外の入力をはねてくれといわれたことがあって、このコードがわかんなかった。調べた限りでは「\xA5[\xA0-\xF6]」である。間違ってるかも。
　文字コードはこのページが参考になりました。「文字コード表」。EUCだけでなく、JIS/SJISのコードもここでわかります。

●おまけ　スクリプトの文字コードを自動判定

# スクリプトの文字コードを自動判定
# $aaa = &getmojicode;　のように呼び出す
sub getmojicode {
	my $hanbetu= "文字コード判別用";
	my $lang = &jcode'getcode(\$hanbetu);
	return $lang;
}

●おまけ2　Macperlへの組み込み

　オフィシャルページから最新版をダウンロードし、MacPerlフォルダの「site_perl」フォルダの中にコピーするだけ。

Jcode.pmのインストール　▲ページトップ　▲▲HTMLに役立つヒント

　MacPerlにJcode.pmをインストールしたときの覚え書き。なお、MacPerl 5.6xでは最初から組み込み済み。

　コンパクトカメラニュースページからRSSファイルを自動生成するスクリプトをかいた。このとき、RSSはUTF-8出力が推奨されているので、jcode.plでは処理できず、Jcode.pmをインストールした。

1.　zipまたはtar.gzをダウンロードする。http://openlab.ring.gr.jp/Jcode/index-j.html
2.　適切に解凍する。StuffIt Expanderでよい。「Jcode-0.83」というフォルダができる。
3.　インストールする。Jcode-0.83の中の「mac_install.pl」というファイルをMacPerlで開き、実行する。
4.　MacPerl ﾄフォルダの下に「site_perlJcode」というフォルダが生成される。このフォルダの名前を「Jcode」に変更する。
5.　変更した「Jcode」フォルダをMacPerl ﾄフォルダの下にある「site_perl」フォルダの中に入れる。

　以上で終わりである。

　ただし、この方法でインストールしても、スクリプトを「Runtime Version」で保存した場合、エラーがでる。CGIやDropletで実行する場合は問題ないので、ダブルクリックで立ち上げ、即実行するような場合はDropletにするといいでしょう。

　使い方の簡単な説明。

　●宣言する。　use Jcode;
　●$aaaをUTF-8に変換する。　Jcode::convert(\$aaa, 'utf8') ;
　　　# 変換は"jis", "sjis", "euc", "ucs2", "utf8"のどれかを指定。

　こちらに詳しい使い方がある。

Encode.pmの覚え書き　▲ページトップ　▲▲HTMLに役立つヒント

　perl 5.8から導入された文字コード変換モジュール。正直、まだよくわかってません。以下、見よう見まねです。

●文字コードを調べる

use Encode::Guess; # モジュールの宣言
$mojicode = (guess_encoding( $aaa, qw/ euc-jp shiftjis 7bit-jis utf8 / ))->name;
# これで$mojicodeに文字コードが入る
# 判定数をもうちょっと増やして置いてもいいかも。7bit-jis ascii euc-jp iso-2022-jp iso-2022-jp-1 shiftjis utf8 iso-8859-1

●文字コードの変換

use Encode (from_to); # モジュールの宣言
$aaa = from_to($moji, "shiftjis", "utf8"); # shiftjisからUTF8へ変換。utf8フラグ付き

　このとき、$aaaに代入せず、「from_to($moji, "shiftjis", "utf8");」とやるとutf8フラグなしとなる。

●文字コードを調べて変換する。

use Encode (from_to);
use Encode qw/ decode encode /;
use Encode::Guess qw/ euc-jp shiftjis 7bit-jis utf8 /;

$allfile = encode( "shiftjis", decode( "Guess",join( undef, $allfile) ));

参考：
・Encode - Walrus,Digit.　Encode 1.7.1の日本語解説。
・Perl 5.8.x における日本語コード変換のメモ　5.8で大きく変わった文字の扱いの解説。実用的で助かる。
・Perl-5.8覚え書き　ここもわかりやすそうです。
・色々TIPS　Perl TIPSにEncodeの話が。

・Jcode　5.8のEncode.pmを使う際、Jcode.pmと同じインターフェースを提供し、ソースの書き換えを最小限にするためのラッパー。同様の物にJEncodeがあります。

Net::FTPの覚え書き　▲ページトップ　▲▲HTMLに役立つヒント

　ざざっとした覚え書き兼スクリプト。たまーにFTPサイトが落ちていておかしくなることがあるので、全体をevalでくるんで続行させてみた。

use Net::FTP;

$hostname = "abcdefg.ne.jp";# 接続先
$loginname = "yourname";# ID　ログイン名
$loginpasswd = "loginpasswd";# ログインパスワード

$basedir ="html" ; # 移動先ディレクトリ

# モード指定
$pasv = "0"; # 0か空ならアクティブモード。それ以外（例：1とかtrue）ならパッシブモード

# evalでエラートラップした。dieすると$@にエラー内容が入る。
eval { 
	$ftp = Net::FTP->new($hostname, Passive => $pasv, Debug => 1); # Net::FTP接続。接続モード$pasv、接続先$hostnameが必要
	
	$ftp->login($loginname, $loginpasswd); # Net::FTPログイン。ID$loginnameとパスワード$loginpasswdが必要
	
	# Net::FTPディレクトリの移動。絶対パスだけでなく、相対パスの指定も可能。$basedir
	$ftp->cwd($basedir) || die("ディレクトリ移動失敗");
	
	# Net::FTP転送モードをバイナリに設定
	$ftp->binary();# ascii/binary/etc mode
	
	# Net::FTP接続先のファイルのリストを得る
	@files = $ftp->dir() || die("リスト取得失敗");
	print join("\n",@files)."\n\n"; 
	
	# Net::FTPファイルのダウンロード。アップロードはput。
	# $ftp->get($name1,$name2) || die("ファイルゲット失敗"); とすると、$name1は元の名前、
	# $name2はダウンして保存するときの名前
	# 保存するローカルディスクの場所を指定したいなら、この前に
	# chdir /xxx/yyy/zzz ; でディレクトリを移動しておけばよい。
	#$ftp->get("filename") || die("ファイルゲット失敗");
	
	# Net::FTPコマンドを実行する。許されないケースもあるようです。
	# 次の例はパーミッションの変更。
	# $ftp->quot('site chmod 0777',$filename);
	
	$ftp->quit; # Net::FTP終了
}; # evalなので}の後ろに;が必要

if($@){ # エラーで止まったら
	print "$@\n"; # エラーを表示。
} else {
	print "終わり\n"; 
}
exit;

　応用というかなんというか。メンテのために、ときどきCGIを止める必要がでてきます。で、FTPで一時的にCGIの名前を変えてしまい、呼び出しできなくさせる、という手法でCGIを止めてます。以下は、最初に「オリジナルの名前（xxx.cgi）→一時的な名前（xxx.cgi.tmp）」に変更を試みて、成功すればCGIはOFF、失敗したら「一時的な名前に変更→オリジナルの名前」を試み、これに成功したらCGIは再びONと。そういう横着なスクリプトです。MacPerlだとダブルクリックでON/OFFできて便利。

　$hostname、$loginname、$loginpasswd、$targetdir、オリジナルファイル名/$orgname、その後ろにつける文字/$tmpnameの設定が必要。

use Net::FTP;
# Net::FTP接続
$ftp = Net::FTP->new($hostname, Debug => 1) || die ("接続失敗。");
# Net::FTPログイン
$ftp->login($loginname, $loginpasswd) || die ("ログイン失敗");
# ディレクトリを移動
$ftp->cwd($targetdir) || die("ディレクトリ移動失敗 $!");
# $orgnameを$orgname$tmpnameに変更できるか試してみる。
eval { 
	$ftp->rename($orgname, "$orgname$tmpname") || die("$orgnameを変更できません。");
}; # evalなので}の後ろに;が必要
if($@){ # 変更できなかったら、今度は逆に$orgname$tmpnameを$orgnameに変更してみる。
	eval { 
		$ftp->rename("$orgname$tmpname", $orgname) || die("$orgname$tmpnameを変更できません。");
	}; # evalなので}の後ろに;が必要
	
	# 結果を確認
	if($@){ # これも失敗した。
		$msg = "\n★★がーん、何らかの原因で名前の変更ができませんでした。\n"; 
		$msg .= "★★すぐにFTPで確認してみてください。\n\n"; 
	} else { # 今度は成功した
		$msg = "\n■■$orgname$tmpnameを$orgnameに戻しました。\n"; 
		$msg .= "■■$orgnameは現在動作しています。\n\n"; 
	}
} else { # 名前変更成功
	$msg = "\n■■$orgnameを$orgname$tmpnameに変更しました。\n"; 
	$msg .= "■■$orgnameは現在動作していません。\n\n"; 
}
$ftp->quit; # Net::FTP終了
print "\a"; # beep
$msg .= "終了しました。\n";
print "$msg";
exit;

レスポンスヘッダを確認する　▲ページトップ　▲▲HTMLに役立つヒント

　サーバのレスポンスヘッダを確認する必要があって、確認用に作ったスクリプト。

$targeturl = "http://mizusawa.no-ip.info:8080/index.html"; # 取得するファイル

use LWP;
# UAオブジェクト生成
$ua = LWP::UserAgent->new;
# $ua->agent("MyApp/0.1 "); # UAのタイプをセット。なくてよい。
# リクエストを投げる
$req = HTTP::Request->new(GET => $targeturl);
# レスポンスの取得
$response = $ua->request($req);
if ($response->is_success) {
	print "\n==============================\n";
	print $response->headers_as_string; # ヘッダ出力
#	print $response->content; # 必要ならファイルの内容を出力
} else {
	print $response->as_string; # エラーヘッダ出力
#	print $response->error_as_HTML; # HTML形式ならこっち。
}
print "\a"; # ビープ
exit;

　こちらのページでは、リクエストヘッダとレスポンスヘッダの両方を確認できる。http://web-sniffer.net/

サブルーチンの引数　▲ページトップ　▲▲HTMLに役立つヒント

　サブルーチンに引数を引き渡すことができる。perlでは呼び出されるときに自動的に「@_」という引数用の配列が用意される。これは通常の配列変数と同じように扱うことができるので、引数の引き渡しと取り出しは次のような感じになる。

&heyhey_baby("ヘイヘイ、ベイベー" , "ダサイって何が？" , "今どきダサイってゆーほーがダセーや" ) ;
exit;

sub heyhey_baby {
	print "$_[0]、お茶しない？\n";
	print "$_[1]\n";
	print "$_[2]、ちぇ！\n";
}

●実行結果
ヘイヘイ、ベイベー、お茶しない？
ダサイって何が？
今どきダサイってゆーほーがダセーや、ちぇ！

　引数が一つしかないなら受け取り側のsubでは「$_」で取り出せる。

SSIでshtmlとplの受け渡し　▲ページトップ　▲▲HTMLに役立つヒント

●.pl側　→.shtml　.plファイルからshtmlに結果（ここでは$kekka）を引き渡す時。

printf ("%5d" , $kekka ) ; # 右詰め5桁の場合

printf ("%s" , $kekka ) ; # 文字列の場合

●shtml側　→.pl

　送りだすshtml側　<!--#EXEC cmd="./kbget.pl test"-->　.plファイル名　半角スペース　引数　となる。

　取り出す.pl側は　$ARGV[0]　を使う。

メールアドレスをエンティティ化　▲ページトップ　▲▲HTMLに役立つヒント

　掲示板などに掲載されているメールアドレスを収集してスパムを送信する輩がいます。安心して掲示板に書き込んでもらうために、メールアドレスを実態参照させるように変更しておくのも一つの手。

use HTML::Entities; # 標準モジュール。
$email = encode_entities($email,"\x00-\xff");　または　encode_entities($email,"\x00-\xff");

　これだけでOK。ただし、これをやっても、そのうちエンティティ化されたアドレスを収集して元に戻すようなツールが出回りそうな気もする。

　なお、デコードはこうする。

$email = decode_entities($email);　または　decode_entities($email);

CGIエラーのトラップ　▲ページトップ　▲▲HTMLに役立つヒント

　デバッグのためによくこんなことします。

open(OUT, "> $filename")|| &syserror("$filenameが開けませんでした。");

　普通「|| die "なんたらかんたら";」とする代わりに上のように呼び出します。ブラウザ上でエラーを表示してくれます。

# CGIエラー表示===================================
# dieのかわりに&syserror("エラー内容"); で呼び出す。
sub syserror { 
#	my ($dat_file,$html);
	my $error = @_[0] ; #雛形ファイルの指定

	print "Content-type: text/html; charset=EUC-JP;\n\n";
	print "CGIでエラーが起きました。";
	print "<p>$error";
	exit;
}

タイムアウト処理　▲ページトップ　▲▲HTMLに役立つヒント

　ALARMシグナルを送って処理を中断させてやります。

# =========================================
#　基本的なやり方
# =========================================
$SIG{ALRM} = \&timeout; # ALRM シグナルをキャッチした場合の処理を定義
alarm 1;  # タイマーを1秒にセット（1秒後にALRMシグナルを送りなさいということ）

#タイマーで時間を監視したい処理
$y = '0';
for ($x=0; $x < 1000000; $x++){
	$y++;
}

# 時間内ならそのまま処理続行
alarm 0; # タイマーリセット
print "$y\n";
exit(0);

#タイムアウトした際に実行する処理
sub timeout {
	print "\a"; # ビープ
	print "時間切れだよ。\n";
	exit(0);
}

　が、上の方法はトラブルがでることもありますので、evalでくるんだ方が無難。

# =========================================
#　evalでくるんだ方がトラブルが少ない。
# =========================================
eval {
	$SIG{ALRM} = sub {die "Time OUT !"}; # 時間切れの処理をセット
	alarm 1; # タイマーを1秒にセット
	
	#タイマーで時間を監視したい処理
	$y = '0';
	for ($x=0; $x < 1000000; $x++){
		$y++;
	}

	alarm 0; # タイマーリセット
};
# タイムアウトしようが正常だろうがここにくる。
alarm 0; # タイマーリセット

# タイムアウトしたかどうかの判定と処理
if($@){ # 時間切れの場合特殊変数$@にエラーが入る
	print "\a"; # ビープ
	print "$@\n";
} else {
	print "OK。\n";
}
exit(0);

パスらから名前を取り出す　▲ページトップ　▲▲HTMLに役立つヒント

　パス（例えば「/xxx/yyy/zzz/」）からファイル名、ディレクトリ名を取り出すルーチン。

$aaa = "/xxx/yyy/zzz/";
$bbb = &getlastname($aaa);
print "$bbb\n";
exit;

# ==========================
# パスからファイル/ディレクトリ名を取り出す
# $aaa = &getlastname(パス);　で呼び出す
sub getlastname {
	my $thispath = $_[0];
	my @pathlist = split( /\//, $thispath ); # /で分解
	# ここ、MacPerlなら:で分解
	my $thisname = pop(@pathlist);
	return $thisname;
}

ソートに関するメモ　▲ページトップ　▲▲HTMLに役立つヒント

　ソートはsort関数を使う。基本はこんな感じ。

@newlist = sort @list; # 文字列のソート
@newlist = sort { $a<=>$b } @list; # 数値なら数値として、文字列なら文字としてソート。昇順。降順なら$a/$bを逆にする。

　で、困ったのが「項目1（tab）項目2（tab）項目3（tab）項目4」というデータを項目3でソートする場合。これはこんな感じでソートできる。[2]となってますが、これは項目が0から始まるためで、3番目の項目は2となります。カンマ（,）区切りなら「\t」を「\,」とすればよい。

@newlist = sort { (split(/\t/,$a))[2]<=>(split(/\t/,$b))[2]; } @list;

　応用編。3番目の項目でソートし、次に1番目の項目でソートする場合はこんな風。

@newlist = sort { (split(/\t/,$a))[2] <=> (split(/\t/,$b))[2] || (split(/\t/,$a))[0] <=> (split(/\t/,$b))[0] } @list;

自分のいるパスを知る　▲ページトップ　▲▲HTMLに役立つヒント

　最も簡単な方法はこれだと思う。自分のいるディレクトリまでのパスがわかる。

use Cwd;
$dir = getcwd;
print "dir : ".$dir."\n";

　スクリプト名（自分自身）も含めて知りたい場合は特殊変数「$0」を使うとよい。

$dir = $0 ; # スクリプトパスを取得（$0は特殊変数）
print "dir : ".$dir."\n";

文字列の中に特定の文字があるか調べる　▲ページトップ　▲▲HTMLに役立つヒント

$結果 = ( $文字列 =~ m/[調べたい文字を正規表現で]/) ; #調べたい文字がなければ結果は空になる。否定形は「!~」

$aaa =~ m/<a href="(.*?)">(.*?)<\/a>/i;
$url= $1; # URLの取り出し
$title = $2;# タイトルの取り出し

　上の応用で、部分取り出しルーチンを作ってみた。

####テスト用のスクリプト。
$aaa = "<!--■begin■-->\n";
$aaa .= "この部分を取り出したい\n";
$aaa .= "<!--■end■-->\n";

$bbb = &toridasi($aaa,"<!--■begin■-->","<!--■end■-->");
print "$bbb\n";
exit;
######テスト用のスクリプトここまで。以下、取り出しルーチン本体。
######うまくいけば「\nこの部分を取り出したい\n」が取り出せる。

#特定の部分を取り出すルーチン
# $aaa = &toridasi(対象文字列,開始文字列,終わり文字列);のように呼び出す
sub toridasi{
	my $mojiretu = $_[0];
	my $begin = @_[1];
	my $end = @_[2];
	$mojiretu =~ m/$begin(.*?)$end/is;
	my $toridasi= $1; 
	return $toridasi;
}

---

　んじゃ、取り出したヤツに変更を加えて元のところに書き戻すにはどうするか。これは置換すればよい。上のスクリプトの続きで、「\nこの部分を取り出したい\n」（$bbb）を「\nこの部分を書き戻し\n」に変えるにはこうする。

$ccc = "\nこの部分を書き戻し\n";
$aaa =~ s/<!--■begin■-->$bbb<!--■end■-->\n/<!--■begin■-->$ccc<!--■end■-->\n/g ;

HTMLをそのまま出力する　▲ページトップ　▲▲HTMLに役立つヒント

　これはヒアドキュメントといわれる方法。「<<」の直後にデータの終わりを示す文字列を指定すると、その間の文字列がそっくりひとかたまりのデータとして扱われます。この中では#もコメントではなく文字列として扱われます。

print "Content-type: text/html; charset=EUC-JP;\n\n";
print <<"_HTML_";
<HTML>
<HEAD>
<TITLE>KINOBOARDS/1.0 kbTst.cgi</TITLE>
</HEAD>
<BODY>
<H1>こうするとHTMLのまま出力できるよ</H1>
<P>　こんな感じで書くとHTMLのまま出力できて、ページ設計の時にラクチン。　<BR>
　「_HTML_」は別になんでもオッケー。例：「_PAGE01_」など。　<BR>
　「#」も制御構造文も文字列になっちゃうよ。</P>
_HTML_

　いったん変数に入れてしまうという方法もある。全体をまとめて文字コード変換したりという場合はこちらの方が便利だろう。

$html = <<"_HTML_";
Content-type: text/html; charset=EUC-JP;
<HTML>
<HEAD>
<TITLE>KINOBOARDS/1.0 kbTst.cgi</TITLE>
</HEAD>
<BODY>
<H1>こうするとHTMLのまま出力できるよ</H1>
<P>　一回変数の中に全部入れちゃう。<br>　あとで全体をまとめてなんかしちゃいたいときに便利。</P>
_HTML_
&jcode'convert (*html,euc) ; # $htmlをeucに変換

エンコードでヘッダを書き分ける　▲ページトップ　▲▲HTMLに役立つヒント

$encode = ""; # エンコードの設定。sjis,euc
if ( $encode eq "sjis") {
$cset = "Shift_JIS";
} else {
if( $encode eq "euc"){
$cset = "EUC-JP";
}
}
print "Content-type: text/html; charset=$cset;\n\n";
print <<"_HTML_";
<html>
<head>
<title>タイトル</title>
<meta http-equiv="Content-Type" content="text/html; charset=$cset">
</head>
_HTML_

小数点第n位で四捨五入する　▲ページトップ　▲▲HTMLに役立つヒント

●汎用ルーチン

sub floating_round {
	if ( @_[1] = "" ) { @_[1] = 1 ; } # 桁数指定が空なら1にする
	if ( @_[1] = "0" ) { @_[1] = 1 ; } # 桁数指定が1なら2にする
	$a = int ( $_[0] *(10**@_[1]) +0.5 )/(10**@_[1] );
}

　考え方は単純で、例えば小数点第3位で四捨五入したいなら、まず100倍して+0.5する。これをint関数で整数に丸めて、もう一度100で割れば小数点第2位の数値になる。
　呼び出す場合は　&floating_round(数値 , 整形後の桁数)　となる。上記の例では結果を得たい桁数は小数点第2位なので、(数値, 2)となる。
　上のルーチンでは小数点第n位を第2引数として受け取り、10のn乗している。このとき、省略されたり0だと計算結果が0になるのでnは1プラスしてやらなくてはならない。

●個別の場合
　丸める桁数がわかっているならわざわざサブルーチンを呼ぶ必要はない。前述の例のように小数点第3位で丸めるには次のようにすればよい。

　$a = int ( $_[0] *100 +0.5 )/100;

カンマ（,）で位取りする　▲ページトップ　▲▲HTMLに役立つヒント

　「123456」を「123,456」のように位取りするためのルーチン。

$kekkaout = &comma($kekka); # カンマ(,)で位どりする

# 位取りルーチン
sub comma {
 local($_) = @_;
 1 while s/(.*\d)(\d\d\d)/$1,$2/;
 $_;
}

●で、こっちは位取りをとるルーチン
　呼び出すときは「&de_comma($aaa)」というように引数で引き渡す。じかに書いてもいいですが。

# 数字の位取りを取り除くルーチン
sub de_comma {
	local($_) = @_ ;# 引数を変数に
	$_ =~ s/,//g; # カンマをとる
}

スクリプトの処理時間を計る　▲ページトップ　▲▲HTMLに役立つヒント

### 計算時間測定開始
### スクリプトの頭の方に書く
$CPU_start = (times)[0] ;


### 計算時間測定終了
### スクリプトのHTML出力部分に書く
	$CPU_end = (times)[0];
	printf("<DIV align=right>消費時間： %.3f CPU秒</DIV>\n",$CPU_end-$CPU_start);

（これの出典はPerl Streetのアクセスログ解析から）

日付と時間を出力する　▲ページトップ　▲▲HTMLに役立つヒント

●最も簡単なやり方

	# 日時を出力する
	($sec, $min, $hour, $mday, $mon, $year) = localtime(time);
	$year = $year + 1900;
	$mon= $mon + 1;
	print "<br>［作成日：$year 年$mon月$mday日$hour時$min分$sec秒］";

●↓汎用版ルーチン。ファイルの修正日などを取得した後、変換するためのもの。呼び出すときに「$aaa = &change_time(time);」とすれば上と同じで現在時刻を返す。「$aaa = &change_time(秒数);」とすればその秒数の年月日を返す。

# ===================================
# 秒数を日時に変換
# $aaa = &change_time(秒数); のように呼び出す。
sub change_time { 
	my $thistime = $_[0];
	local($lsec, $lmin, $lhour, $lmday, $lmon, $lyear,$lthis_day);
	($lsec, $lmin, $lhour, $lmday, $lmon, $lyear) = localtime($thistime);
	$lyear = $lyear + 1900 ; # 年を整える
	$lmon = $lmon + 1 ; # 月を整える
	# 以下、1桁の場合頭に0をつける。必要に応じて削除すること。
	if ( length($lmon) == 1 ) { $lmon = "0$lmon" ; } # 1バイトなら頭に0を付ける・月
	if ( length($lmday) == 1 ) { $lmday = "0$lmday" ; } # 1バイトなら頭に0を付ける・日
	if ( length($lhour) == 1 ) { $lhour = "0$lhour" ; } # 1バイトなら頭に0を付ける・時
	if ( length($lmin) == 1 ) { $lmin = "0$lmin" ; } # 1バイトなら頭に0を付ける・分
	if ( length($lsec) == 1 ) { $lsec = "0$lsec" ; } # 1バイトなら頭に0を付ける・秒
	$lthis_day = "$lyear/$lmon/$lmday $lhour:$lmin:$lsec" ; # 2002/08/06　14:05:30形式
 # $lthis_day = "$lyear$lmon$lmday $lhour:$lmin\'$lsec" ; # 20020806 140530形式
 # $lthis_day = sprintf("%04d\/%02d\/%02d\(%s\) %s%02d\:%02d", $lyear+1900,$lmon+1,$lmday,$lhour,$lmin,$lmin);

	return $lthis_day;

 # ↓こんなふうにして、($year,$month,$day,$hour,$min,$sec) = &change_time(秒数);で呼び出すと、年月日時分秒がそれぞれ入る
	# return ($lyear,$lmon,$lmday,$lhour,$lmin,$lsec); 
}

上のルーチンをもっと簡略化して書くとこうなる。

# ===================================
# 秒数を日時に変換
# $aaa = &change_time(秒数); のように呼び出す。
sub change_time { 
	my $thistime = $_[0];
	local($lsec, $lmin, $lhour, $lmday, $lmon, $lyear,$lthis_day);
	($lsec, $lmin, $lhour, $lmday, $lmon, $lyear) = localtime($thistime);
	$lthis_day = sprintf("%04d\/%02d\/%02d\ %02d\:%02d:%02d", $lyear+1900,$lmon+1,$lmday,$lhour,$lmin,$lsec); # 2002/08/06 14:05:30形式
	return $lthis_day;
}

●↓上と反対に、年月日時分秒から秒数を算出するにはTime::Localモジュールを使う。こんな感じ。時間は24時間制で指定する。

use Time::Local;
$times = timelocal($sec,$min,$hour,$day,$month-1,$year);

●↓現在の秒数を得たいならこうする。

$time = time();

●↓ついで。年月を与えると、その月の末日を返すルーチン。「$aaa = &getmaxday(2000,2);」すると$aaaには29（日）が入る。

# ===================================
# 年月を与えると、その月の末日を返す。
# $aaa = &getmaxday(年,月); のように呼び出す。
sub getmaxday { 
	local ($lyear,$lmonth) = @_;
	local (@months,$lthismonth);
	local $lbigmonth = "1,3,5,7,8,10,12"; # 大の月
	local $lmaxday = 30;
	if ($lmonth == 2){ # 2月なら
		$lmaxday = 28;
		# 閏年のチェック。4で割りきれる年は閏年だが、100で割りきれる年のときは閏年ではない。ただし400で割りきれる年は閏年。
		# 4で割りきれる年のうち( 100で割りきれない年、または400で割りきれる年 )は閏年、となる。
		if ($lyear % 4 == 0 and($lyear % 100 != 0 or $lyear % 400 == 0)){
			$lmaxday = 29;
			# この部分の判定を使ってうるう年のチェックも可能。年を渡してうるう年なら1、その他は0を返すなんてのが吉。
		} 
	} else {
		@months = split( /,/, $lbigmonth );
		foreach $lthismonth ( @months ) { # 大の月なら
			if ($lthismonth == $lmonth){$lmaxday = 31;}
		}
	}
	return $lmaxday; 
}

　なお、MacPerlとUNIX perl両用のスクリプトを書くときには、両者の時間の起点の違いに注意が必要です。「mac/unix」を参照してください。

ファイルの更新日を取得する　▲ページトップ　▲▲HTMLに役立つヒント

	# 更新日時の取得
	$modtime = (stat($file))[9] ; # $fileはファイル名
	($sec, $min, $hour, $mday, $mon, $year) = localtime($modtime); localtimeで現地時間に変換
	$year = $year + 1900;
	$mon= $mon + 1;
	print "<br>［作成日：$year 年$mon月$mday日$hour時$min分$sec秒］";

ディレクトリにあるファイル数を取得する　▲ページトップ　▲▲HTMLに役立つヒント

　正確には、ディレクトリのファイル名を調べて、特定のファイル名を含む（$dono_file）ファイルを数えてます。これ、アンケートのデータファイルを新しい名前にリネームしてバックアップとしてとっておく目的で作ったルーチン。aaaがファイル名だとしたら、aaa1、aaa2というようにリネームさせていくわけ。
　なお、readdir(DIR)でディレクトリに含まれるファイル名/ディレクトリ名を取得すると、「.」「..」という上のディレクトリに戻るための名前もゲットするので注意。
　また、readdir(DIR)はディレクトリ名もファイル名も一緒くたに取得しますから、区別したいならreaddir(DIR)のあとにforeachでひとつづつ取り出すときに「if (-d $_) {処理}」という風にすればいいでしょう。「-d」はそれがディレクトリだったら1を返してきます。ファイルであることを確認してから処理するなら「- f」を使い、「if (-f $_) {処理}」という感じ。

&filenum($target_dir) ; # $target_dirにディレクトリを記述しておく

# ファイル名を取得して、合致するか調べる
sub filenum {
	local($dir) = $_[0];
	local(@filelist, $filename);
	opendir (DIR , $dir) || die "Cannot open dir $dir" ;
	@filelist = readdir(DIR);
	closedir(DIR) ;
	foreach $filename (@filelist) {
		$target_file = ( $filename =~ /$dono_file/) ; # 調べたい文字がなければ結果は空になる。
			if ( $target_file ne "" ) { # 空でなければcountをあげる
				$count = $count+1;
			}
	}
}

　で、この後リネームするにはこんな感じ。ファイルをいじるときにはopendirではダメなのね。chdirでないと。これに気がつくまで時間を食っちまったぜ。
　リネーム自体は、rename(古い名前 , 新しい名前)　とする。

# ●そのファイル数をファイル名の最後につけてリネームする
chdir($target_dir);
$newfile = "$dono_file$count";
rename("$dono_file","$newfile") ;

　単純にファイルのリストを得るならこんな感じ。ただし、リストを取得したら、「.」（一つ上のディレクトリ）、「..」（二つ上のディレクトリ）には注意。何か処理するならこれらを飛ばすことを忘れずに。

# =====================================
# ファイルのリストを得る。
# @filelist = &get_filelist(ディレクトリ名) ; のように呼び出す
sub get_filelist {
	my($dir) = $_[0];
	opendir (DIR , $dir) || die "Cannot open dir $dir" ;
	my @filelist = readdir(DIR);
	closedir(DIR) ;
	return @filelist;
}

NET::SMTPでメール送信　▲ページトップ　▲▲HTMLに役立つヒント

　NET::SMTPモジュール（標準モジュール）でメール送信する。日本語のタイトルをエンコードするためにMIME::Base64モジュール（標準モジュール）も必要です。文字コードの変換にjcode.plも。

　もしはいっていなかったら、これらを別途インストールする必要があります。

　通常、perlからメール送信する場合、sendmailという別サーバに操作を投げます。すると、メール送信はsendmailに任せて、perlスクリプトはどんどん次の処理をしていけます。しかし、ここで紹介するモジュールを使った方式では、perl以外必要ないかわりに、スクリプトの中でメール処理をしますから、メール送信が終わらないと次の処理に移りません。ぶっちゃけ、全体の動作が遅くなります。よその（SMTP）サーバとやり取りするので、回線スピードも影響します。

# ================================================
# 変数の設定
# ================================================
$server = "smtp.domain" ;# 利用するSMTPサーバ名かIPアドレス
$from = "name\@domain" ;# 送信元アドレス　\@に注意
$to = "name\@domain" ;# 宛先アドレス　\@に注意

# ================================================
# メインルーチン
# ================================================
use Net::SMTP;
use MIME::Base64 ;
require 'jcode.pl';
$mailtitle = "これはテストメールです"; # タイトル
$mailbody = "これはてすとです。\n"; # 内容
$mailbody .= "うまく日本語が送信できるかな？\n"; # 内容
&smtp_mail($mailtitle,$mailbody) ; # 送信ルーチン呼び出し
print "送信終わり\n";
exit;

# ================================================
# サブルーチン
# ================================================
# ======================================
# メールを送信するルーチン
# &smtp_mail(タイトル,内容) ;　で呼び出す。
# Net::SMTPとMIME::Base64モジュールが必要。
sub smtp_mail {
	my ($mailtitle,$mailbody) = @_;
	&jcode'convert (*mailtitle,jis) ;
	&jcode'convert (*mailbody,jis) ;
	# タイトルはBase64エンコードする（本文はJISでよい）
	$mailtitle = MIME::Base64::encode($mailtitle,""); # 75バイトで改行されないように空を指定
	$mailtitle = "=?ISO-2022-JP?B?"."$mailtitle"."?="; # 前後におまじない
	$smtp = Net::SMTP->new($server); # 送信開始
	
	$smtp->mail($from);
	$smtp->to($to);
	
	$smtp->data();
	$smtp->datasend("To: $to\n"); # 送信先
	$smtp->datasend("Subject: $mailtitle\n"); # タイトル
	$smtp->datasend("Content-Type: text/plain; charset=\"ISO-2022-JP\"\n"); # コード指定
	$smtp->datasend("\n"); # ヘッダ、ここまで
	$smtp->datasend("$mailbody\n"); # 内容
	$smtp->dataend(); # データここまで
	
	$smtp->quit; # 送信命令
}

テストルーチン　▲ページトップ　▲▲HTMLに役立つヒント

　cgiが動くかどうか、基本的なところをテストするためのルーチン。頭の方におきましょう。

# CGIテスト用
# ブラウザから「なんとか.cgi?test」という風にアクセスしてテストします。
# Script OKと表示されたら無事動きます。macでは動作しません。
if ("$ARGV[0]" eq "test") {
	print "Content-type: text/html\n";
	print "\n";
	print "CGI Script OK.\n";
	exit(0);
}

　出典はとほほさんの「wwwsrch.cgi」。

配列@の要素の数を調べる　▲ページトップ　▲▲HTMLに役立つヒント

　配列（リスト）の数を知りたい場合。あまりに単純でわかんなかった(^^;

@tmp=(1..100); # 配列（リスト）を用意
$num = @tmp; # 要素の数を調べる。これだけなんですね。
print "$num\n";

配列からまんべんなく重複せずにランダムに取り出す　▲ページトップ　▲▲HTMLに役立つヒント

　9つのフラッシュファイルがあって、一覧画面にその9つの画像をランダムに並べたいと。で、作ったもの。

　特定の並び（配列）の中から、「まんべんなく」しかも「重複せずに」ランダムに取り出す、ということですね。

　最初に用意した配列からランダムに一つとりだして取っておき、今取り出した要素を元の配列から削除する。これを配列の要素がなくなるまで繰り返せば、（既出の要素は削除されるので）重複なくランダムに取り出せることになる。という考え方で書いたのが次のスクリプト。

@arrey = (1..9); # 配列を用意。数字でなくとも次行のような要素でもOK
# @arrey = (aaa,bbb,ccc,ddd,eee,fff,ggg,hhh,iii,jjj);
$x = @arrey; # 配列の個数を取得

for ($i=1; $i<=$x; $i++) {
	# print "@arrey\n"; # 元になる@arreyを表示。行頭の#を外すと動作がわかりやすくなる。
	$num = int(rand @arrey); #@arreyの要素数を最大値として乱数発生
	@order[$i] = @arrey[$num]; # @arreyのその番号の要素を取り出してorderへ。
	splice(@arrey,$num,1);# @arreyのその要素を削除
}

for ( $i=1; $i<=$x; $i++) { print "$order[$i]・"; }# 結果をプリントしてみる。
print "\n";

　スクリプトを見るとわかりますが、最初の「$order[0]」は空になります。iが1から始まっているから。これ、「0から8番の9個」と考えるより、「1から9番の9個」と考えた方があとの処理が直感的にできるのでそうしました。

　で、上の考え方をもうちょっとスマートに書くとこうなります。配列を@arrey = (1..20)とかして試してください。

@arrey = (1..9); # 配列を用意。
$x = @arrey; # 配列の個数を取得

@order[0] = ""; # 最初の配列に空を入れる。すると次にpushすると@order[1]以降に入っていく。

for ($i=1; $i<=$x; $i++) { # ここがキモ
	push (@order, splice(@arrey, int(rand @arrey), 1)); 
}

for ( $i=1; $i<=$x; $i++) { print "$order[$i]・"; }# 結果をプリントしてみる。
print "\n";

パッチ　▲ページトップ　▲▲HTMLに役立つヒント

　perlコマンドではないですが、自分で使うもんでここに。

●パッチファイルを作る　diff

　差分ファイルを作りたいディレクトリにいって、「diff -c file1 file2 > patch.diff」とする。file1をファイル2にアップするための差分ファイルpatch.diffを作る、という意味。-cオプションを付けないと差分ファイルに元ファイルの情報が含まれないので注意。

●パッチを当てる　patch < パッチファイル

　パッチを当てるファイルのあるディレクトリにパッチファイルを置く。このディレクトリで「patch < パッチファイル名」とすれはOK。

掲示板のスパム対策の例　▲ページトップ　▲▲HTMLに役立つヒント

　掲示板に対するスパム対策ルーチンをいくつか。あくまで例なので、実用にするにはそれぞれ掲示板スクリプトに合わせて手を入れてね。

●外国からのスパム対策。本文中にひらがなが一文字もないと外国からのスパムと判断する。この方法、例えば「賛成に一票」は通るけど、「賛成」という一言コメントは通らなくなるので注意。

　テストスクリプト。$aaaが本文と思ってください。

$aaa = "sldakfljfeaoieirojij";
if ($aaa !~ /\x82[\x9f-\xf1]/) { # スクリプトがSJISの場合
# if ($aaa !~ /\xA4[\xA1-\xF3]/) { # スクリプトがEUCの場合
# if ($aaa !~ /[ぁ-ん]/) { # スクリプトがJperlの場合
	print "Noooo!断固拒否なのだ｡必要に応じてエラーに飛ばしてね\n";
} else {
	print "OK!書いていいよ｡フツー、ここは何もせずにスルーする\n";
}

●URL（ホームページ欄）と同じURLが本文中にあったら宣伝と判断する。$urlがurl欄、$commentが本文。

# URLと同じものが本文にあったら宣伝なのでオミット
if ($url ne ""){ # URLが空でなければ
	if ( $comment =~ m/$url/) {
		print "宣伝はだめよ。必要に応じてエラーに飛ばしてね";
	}
}

●禁止語チェック。禁止語ワード自体は別ファイルにしておいて、1行1データで記述しておく。禁止語のチェックには、必要に応じて名前、URL欄、mail、本文をルーチンに渡してやる。

　下の例では、これらをまとめて渡しているので、1度のチェックでこれらの欄をまとめてチェックできる。したがって禁止語にはURLやmailを指定しておいてもOK。

# 禁止語ファイル名。スクリプトの設定部分に追加。
$omitwdfile = "omitwd.dat";

# 適当な位置でチェックを呼び出す。
&omitwd("$name\t$url\t$mail\t$comment");

# ===================================
# 禁止語チェックルーチン
# &omitwd(チェックしたい内容); のように呼び出す。チェックしたい内容は、必要に応じて
# "$name\t$url\t$mail\t$comment"などのようにまとめて渡す。
sub omitwd {
	my $content = $_[0];
	my $flag = ""; # フラグの初期化
	# ファイルのオープン
	open (OMIT,"<$omitwdfile")|| die "ファイル「$omitwdfile」が開けません";
	#ファイルの読み込み
	foreach $thiswd (<OMIT>){ # 1行ずつ処理する。メモリを食わない
		# 必要があれば文字コードを変換する。最初からコードを合わせておく方がよい
		# &jcode'convert (\$thiswd,euc) ;
		chomp ( $thiswd ); # 改行を取る
		if (index($content,$thiswd) >= 0) { # 禁止語があったら
			$flag=1; # フラグを立てて
			last; # 処理を抜ける
		}
	}
	#ファイルのクローズ
	close (OMIT) ;
	if ($flag eq "1" ){# フラグが立っていたら
		print "発言できません。どうしても発言できない場合は、管理者にご連絡ください。\n";
		print "ここは必要に応じてメールやエラールーチンに飛ばすなどする。\n";
		print "メールの際には、内容だけでなく、$thiswdを一緒に渡してやるとなんで禁止されたかわかる。\n";
	}
}

　禁止語チェックで一番難しいのは、どんな言葉を禁止語に指定するのか、ということなんですね。下手な言葉を禁止語に指定しておくと、「濡れ衣」を着せかねないんです。なので、禁止語で弾いたら、一応自分の所にメールするようにしておくといいと思います。上の例のように「発言できない場合は管理者に連絡を」で済ませるという手もありますが。

　たいていの掲示板CGIにはIPアドレスによる発言拒否機能が付いていますが、スパマー側もわかっていて、アクセスのたびにIPアドレスを変える手法が一般化していてスパムに対しては効果が望み薄になっています。スパムよりも相対的に技術力の低い掲示板荒らしに対しては、IPアドレスチェックもまだ効果があると思われます。IPアドレスチェック機能はたいていの掲示板スクリプトに備わってますので、禁止語と併用するといいでしょう。

●発言者名・タイトル・URL、メールアドレスに文字数制限をかける。

　発言者名やタイトル、メールアドレス、ホームページ欄に本文というか大量のアドレスを書き込むという手口のスパムもあるようです。

　これらの欄には、1.文字数制限をする、2.発言者欄・タイトル欄に「http://」がでてきたらはじく、3.ホームページ欄に「http://」が2回以上でてきたらはじく、といったところでしょうか。こんな感じ。メールアドレスには別途アドレスのチェックも施すこと。

	$err = ""; # エラー内容の初期化
	if (!$name){ # 名前は必須
		$err .= "・『お名前』の記述がありません。<BR>\n";
	} else {
		if (length $name > 40){ # 40バイト以上だとダメ
			$err .= "・『お名前』が長過ぎます。<BR>\n";
		}
		$name2 = $name;
		$name2 =~ s/ //g ; # 半角スペースを削除してチェック
		if (length $name2 < 3){ # 3バイト以下だとダメ
			$err .= "・『お名前』が短過ぎます。<BR>\n";
		}
		if ($name =~ /[http|https|ftp]:\/\//){ # http://があるとダメ
			$err .= "・『お名前』が不正です。<BR>\n";
		}
	}
	if (!$title){ # 名前は必須
		$err .= "・『タイトル』の記述がありません。<BR>\n";
	} else {
		if (length $title > 80){ # 80バイト/40文字以上だとダメ
			$err .= "・『タイトル』が長過ぎます。<BR>\n";
		}
		if ($title =~ /[http|https|ftp]:\/\//){ # http://があるとダメ
			$err .= "・『タイトル』が不正です。<BR>\n";
		}
	}
	if (!$msg){ # 発言内容は必須
		$err .= "・『発言内容』の記述がありません。<BR>\n";
	} 
	if ($url ne ""){ # urlの入力がある場合は
		if (length $url > 100){ # 100バイト以上だとダメ
			$err .= "・『URL』が長過ぎます。<BR>\n";
		}
		# $positionは「://」の位置、$statusは「://」の数
		my($position,$status) = 0;
		while ( ($position = index($url , "://" , $position)) > 0 ){
			$status ++;
			$position ++;
		}
		if ($status > 1){ # 1より多ければエラー
			$err .= "・『URL』が不正です。<BR>\n";
		}
	} 
	if ($email ne ""){ # emailの入力がある場合は
		if (length $email > 100){ # 100バイト以上だとダメ
			$err .= "・『メールアドレス』が長過ぎます。<BR>\n";
		}
	}
	if ($err ne ""){ # なんかエラーがあったらお断り
		print "必要に応じてエラールーチンやエラー表示画面に飛ばしたりしてね。\n";
		print "エラーです。<br>$err\n";
	}

●掲示板CGIによっては、コメント欄に「>元発言の内容」のように最初から引用文が入っているものもあります。この親切を逆手に取り、そのまま「コメント」してURL欄だけ宣伝したいURLに書き換えるという手口もあります。

　これに対抗するには、1.コメント欄に表示した引用文と同じ内容を<input type="hidden" name="checkmoji" value="■ここに引用文と同じ内容■">をformに埋め込んでおき、2.コメントを受けとったときにコメント内容とcheckmojiの内容が一致していたら弾く、という手法を使います。

# ■コメント時に元発言と同じ内容だったらダメ。
if ($comment ne ""){ # コメントが空でなければ
	$cmtcopy = $comment ; # コメントをコピーして
	$cmtcopy =~ s/(\r\n|\n|\r)//g ; # 改行を取る
	$checkmoji =~ s/(\r\n|\n|\r)//g ; # 埋め込んであった引用文からも改行を取る
	if ( $cmtcopy eq $checkmoji) {
		$err = "・この発言は受付できません。<!--■コメント元と内容が同じ■--><BR>\n";
	}
}

●発言・コメント時にランダムな数値（あるいは言葉）を入力させる。
　ロボットによるスパムを排除するのに効果がある。発言・コメントの手間がやや増える。まーまー実用的な範囲か？　こんな感じ。

「55」この数字を入力してください。→

　上のような欄を設けておき、入力値が合っていないと拒否する、というものである。「55」という数字部分はランダムに生成する。改造箇所があちこちに渡るはずなので、perl初心者には改造難易度が高いです。簡単に流れだけ解説します。

・CGIで乱数を発生させる。

$randnum = int(rand 99); #乱数発生
if ( length($randnum) == 1 ) { $randnum = "0$randnum" ; } # 1バイトなら頭に0を付ける。必ずしも必要ないけど一応。

・コメント・発言formに追加。CGIによってCGI内部で生成していたり、別ファイルで設定していたりするので実態に合わせること。$randnumにランダムな数値が入る。別ファイルの場合、埋め込み変数のすり替えも必要になるかもしれない。この部分はJAVAscriptで書くという手もある。

<input type="hidden" name="chk_randnum"value="$randnum">
「$randnum」この数字を入力してください。→
<inout type="text" name="ipt_randnum" size="2">

・CGIの受け取り部
　「chk_randnum」「ipt_randnum」をCGIの実態に合わせてformから変数に取り出し、次のような感じでチェックする。

if($chk_randnum ne $ipt_randnum){ # 両方があっていなかったらダメ
 print "エラーだよ。\n";
}

　そのほか、もっと厳しい対策としては次のような方法があります。

●登録制にする
　一度メンバーとして登録しないと発言できないようにします。この場合、CGIに手を入れるケースと、単純に.htaccessで認証制限をかけ、メンバーだけにIDとパスワードを知らせるという簡易な方法があります。

　いずれの場合も、フツーの発言も激減するデメリットがあります。.htaccessの認証制限だと、メンバー以外は閲覧さえできなくなります。

●検閲制にする
　管理者が内容に目を通してからでないと、発言・コメントができないようにします。CGIを大幅に改造しなくてはいけないこと、管理が大変であること、即時性がないこと、というデメリットがあります。

　参考になりそうなサイトをいくつかリンクしておきます。

●掲示板改造支援サイト　スパム対策が施された掲示板スクリプトを多数配布しています。対策の手法も紹介しています。
●【掲示板スパム投稿 対策サイト】　掲示板に投稿されたスパム例などがあります。禁止ワードの設定などに役立ちます。ここのリンクから他のサイトをたどるといいでしょう。

()の閉じ忘れがないかチェック for SQL　▲ページトップ　▲▲HTMLに役立つヒント

　()の閉じ忘れがないか、簡易にチェックするルーチン。単純に「(」と「)」の数を数えて、一致しているかどうかを見ているので、構文まで見ているわけではない。なので簡易チェック。

　どういう時に使うかというと、MySQLを操作するperlを作ってたんですね。で、例えばSQL文が「SELECT * FROM $tablename WHERE ( year=$year AND month=$month)」だったとします。このとき、SQLに渡すまでは命令文はperlの中ではただの文字列なんで、「SELECT * FROM $tablename WHERE ( year=$year AND month=$month」というように括弧を閉じ忘れていてもperlの構文エラーにはならないです。ところが、いったんSQLに渡すと、perlが無限ループに入っちゃう。そんなことにならないようにSQLに渡す前にチェックしようというもの。

　ついでにおおざっぱなSQLのコントロール例も載せておきます。この例ではSQL文を実行するとき、エラートラップをしかけてますが、()の閉じ忘れはこれも素通りします。

$order = "SELECT * FROM $tablename WHERE ( year=$year AND month=$month)";
&paircheck($order,"(",")"); # SQL文の()がペアかチェックして
&connect_sql; # 接続
&order_mysql($order); # 命令
	$rownum = $sth->rows; # 該当するデータの個数
	for ($i = 0 ; $i < $rownum; $i++){
		@a = $sth->fetchrow_array; # 該当データの取りだし
		print "$a[0]\n$a[1]\n$a[2]\n";
	}
&connect_sql; # 切断
exit;

# ==================================
# (などがペアになっているかチェックする
# &paircheck(調べる内容,対1,対2);　で呼び出す
# 例：&paircheck("aaa(bb)","(",")"); # ()が対になっているか
sub paircheck {
	my($mmoji,$mpair1,$mpair2,$mposition,$mstatus1,$mstatus2);
	$mmoji = $_[0]; # 対1
	$mpair1 = $_[1]; # 対1
	$mpair2 = $_[2]; # 対2
	# 対1の数
	$mposition = 0; # 初期化
	$mstatus1 = 0 ; # 個数1
	while ( ($mposition = index($mmoji , $mpair1 , $mposition)) > 0 ){
		$mstatus1 ++;
		$mposition ++;
	}
	# 対2の数
	$mposition = 0; # 初期化
	$mstatus2 = 0 ; # 個数1
	while ( ($mposition = index($mmoji , $mpair2 , $mposition)) > 0 ){
		$mstatus2 ++;
		$mposition ++;
	}
	if ($mstatus1 != $mstatus2) { # 数が一致しない
		$error = "ヤバイよヤバイよ。「$mpair1」$mstatus1個と「$mpair2」$mstatus2個だ。エラーに飛ばす\n";
		print "$error";
	} else {
		$error = "OKいいよ。$mstatus1個と$mstatus2個だ。\n";
		print "$error";
	}
}


# SQLに接続する===============
sub connect_sql{
	$dbset = "DBI:mysql:$databasename";# データベースの設定
	$db = DBI->connect($dbset,$dbuser,$dbpassword);# データベースに接続
}

# SQLの接続をきる===============
sub disconnect_sql{
	$sth->finish;
	$db->disconnect;
}

# SQLに命令する===============
sub order_mysql{
	my $tosql = $_[0]; # SQL文の受けとり
	$sth = $db->prepare($tosql);
	$errflg = $sth->execute; # SQL文を実行/エラーがあったら入る
	if( not $errflg){ # SQL文にエラーがあったら表示
		$error = $sth->errstr . "<br>\n";
		$error .= $sth->err . "<br>\n";
		&disconnect_sql; # 後処理
		print "Content-type: text/html; charset=EUC-JP;\n\n";
		print "$error"; 
	}
}

フォルダドロップ対応ドロップレット　MacPerl用　▲ページトップ　▲▲HTMLに役立つヒント

　MacPerlのフォルダドロップ対応ドロップレットの雛形。ドロップレットとして保存してください。

　ちなみにこの雛形は、ファイルを読み込んで何も処理せずにそのままのデータを新たなファイルに書き出しています。で、元のファイルを削除して、新しいファイルをrenameして元の名前にしています。perlの作った新しいファイルに置き換わりますから、（perlはリソースフォークを扱えないので）リソースフォークがさっくり削除されます。リソースフォーク削除ツールとして使えるわけです。

　逆に、リソースフォークが必要なものに使うと大変なことになりますのでご注意。

#!/usr/local/bin/
################################################################
# MacPerl用です。普通のperlには使えません。
# フォルダドロップに対応したドロップレットの雛形
# フォルダの中のファイル/フォルダも再帰的に処理します。
# 複数ファイル・複数フォルダはもちろん、混ぜこぜでドロップしても大丈夫。
# ドロップリストは@ARGVに入るので、それがファイルか
# ディレクトリか調べて処理していくというだけ。
# 水沢・penguin-19・和彦　使用・改変などは御自由に。
################################################################

################################################################
# 変数の設定
################################################################
# 一時書き出しファイルに追加する文字列
$kubetu = ".tmp";
################################################################
# メインルーチン
################################################################
# ドロップされたアイテムをファイル/フォルダ判定ルーチンへ飛ばす。
foreach $dropitem (@ARGV) {
	&hantei($dropitem); 
}
print "\a"; # beep
exit;
################################################################
#　以下、サブルーチン
################################################################
# ==================================================================
# ファイルかフォルダかを判定してそれぞれの処理に飛ばす。
# ==================================================================
sub hantei {
	my $thisitem = $_[0];
	$thisitem =~ s/::/:/g ; # ::を:に
	if (-d $thisitem){ # ディレクトリの場合
		&forDir($thisitem) ; # ディレクトリ処理ルーチンに飛ばす
	} else {
		if (-f $thisitem){ # ファイルの場合
			&forFile($thisitem) ; # ファイル処理ルーチンに飛ばす
		} else {
			# ここに来たら変。エラー処理を書く
			print "判定エラー $thisitem\n";
		}
	}
}
# ==================================================================
# ディレクトリ用の処理を書く
# ==================================================================
sub forDir {
	my $dirname = $_[0];
	my (@filelist, $thislist);
	print "\nフォルダだ $dirname\n"; # 
	# このフォルダの下のリストを取得する。
	opendir (DIR , $dirname) || die "Cannot open dir $dirname" ;
		@filelist = readdir(DIR);
	closedir(DIR) ;
	# そのリストを&hantei(リスト);に投げ戻す。再起処理ですね。
	foreach $thislist (@filelist) {
		# MacPerl用なんで処理してないですが、通常のperlに応用するなら、
		# ここらへんに　if ($thislist =~ m/^\./){ などとして、
		# .で始まっていたら飛ばすようにしないとダメ
		my $foldirlist = "$dirname:$thislist";
		$foldirlist =~ s/::/:/g ; # ::を:に
		&hantei("$foldirlist");
	}
}
# ==================================================================
# ファイル用の処理を書く
# ==================================================================
sub forFile{
	my $thisfile = $_[0];
	print "　ファイルだ $thisfile\n";
	open (RSS,"<$thisfile")|| die "ファイル「$thisfile」が開けません";
	open(OUTPUT,">$thisfile$kubetu") unless -e "$thisfile$kubetu"; # 出力ファイルを開く
		while ($_ = <RSS>){
	
			# ここにファイル用の処理を書く
	
			print OUTPUT; # 出力ファイルに書き込む
		}
	close OUTPUT; # 出力ファイルを閉じる
	close RSS; # ファイルを閉じる
	# 元ファイルを削除
	unlink $thisfile ; 
	# .一時ファイルを変更
	rename "$thisfile$kubetu" ,$thisfile; 
}

UVJ Mailerでメール送信機能をつける（MacPerl用）　▲ページトップ　▲▲HTMLに役立つヒント

　UNIX Perl用のスクリプトをMacPerlに書き換える場合、sendmailによるメール送信機能が使えません。そこで田中求之さんのメール送信アプリケーション「UVJ Mailer」を使い、メール送信するためのサブルーチンを紹介しておきます。

　MacPerlスクリプトがsjis以外の場合は、jcode.plが必要です。

　なお、「NET::SMTPでメール送信」で紹介したスクリプトでメール送信することもできますが、スクリプト内部で処理するため、処理に時間がかかります（外部サーバとやりとりするので）。しかし、UVJ Mailerを使えば、メール送信をUVJに投げて、スクリプトはすぐに次の処理に移れます。スピード的に有利なわけです。

●スクリプトの最初の方で指定する。

# UVJ Mailerに登録してあるメール送信先ニックネーム。
# UVJ Mailerはあらかじめ立ち上がっている必要がある。
$mailto = "ニックネーム" ; 
# メール送信するときの発信元メールアドレス。
$frommail = "name\@xxxx.ne.jp"; 
$uvjmailer = "UVJ Mailer 3.1 PPC"; # UVJ mailerの名前

●送信ルーチン

# メール送信==============================
# &mail_to("メールタイトル","メールの内容");　のように呼び出す。
sub mail_to{
	my ($mailSubject,$mailBody) = @_; # タイトルと内容の受け取り
	# スクリプトがsjis以外の場合、sjisに変換する必要がある。
	# 必要なければ次の3行をコメントにする。
	&jcode'convert (\$mailto,"sjis") ;
	&jcode'convert (\$mailSubject,"sjis") ;
	&jcode'convert (\$mailBody,"sjis") ;
&MacPerl'DoAppleScript(<<END_SCRIPT);
tell application "$uvjmailer"
activate
send mail "$mailBody" to "$mailto" from "$frommail" subject "$mailSubject"
end tell
END_SCRIPT
}

●呼び出し方の例
　送信ルーチンの呼び出しは、次のように呼び出します。

&mail_to("メールタイトル","メールの内容");

　メールタイトルや内容を適宜生成してから送信するといいでしょう。こんな感じです。

# タイトルの生成
$mailtitle = "発言がありました。";
# 内容の生成
$mailbody = "●●システムに発言がありました。\n\n";
$mailbody .= "内容は次の通りです。\n";
$mailbody .= "$naiyou\n";
# メール送信
&mail_to("$mailtitle","$mailbody");

　こんな感じです。

深いディレクトリを作る　▲ページトップ　▲▲HTMLに役立つヒント

　UNIX Perlならこんな感じでできます。

use File::Path;
mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); # 作成する
rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); # 削除する

　指定は(バス名 , ブーリアン , パーミッション)です。
　パス名　['xxx','yyy']　でxxxとyyyの2つを作成できる。
　ブーリアン。1だと作成したディレクトリ名を返す。0だと返さない。

　が、なぜかこのモジュール、MacPerlではうまく動作しません。で、こんなルーチンを作ってみました。
（下のルーチンを作ってから気がつきました。「mkpath('xxx:yyy', 1, 0711);」ではだめで、「mkpath(':xxx:yyy', 1, 0711);」のように頭に「:」が必要でした。File::Path、ちゃんと動きます(^^;）

# ==================================
# 深い階層まで一気にディレクトリを作成する
# &makedir("xxx/yyy/zzz");　のように呼び出す
sub makedir{
	my $dir = $_[0];
	my (@dirlist,$thisdir);
	if($pc eq "1"){ # MACなら
		@dirlist = split( /:/, $dir ); # :で分解
	} else {
		@dirlist = split( /\//, $dir ); # /で分解
	}
	foreach $thisdir ( @dirlist ) {
		if($thisdir eq ""){next;} # 空なら無視
		if ($thislist =~ m/^\./){next;} # .で始まっていたら無視
		mkdir("$thisdir");
		chdir("$thisdir");
	}
}

　必要に応じて、処理前にカレントディレクトリを覚えておいて、処理が終わったら元のディレクトリに戻ってください。

$plname = 'makedir.pl'; # スクリプト名

$basedir = $0 ; # スクリプトパスを取得（$0は特殊変数）
$basedir =~ s/$plname$//g ; # スクリプト名を消すと現在のパスが残る
print "$basedir\n"; 
&makedir("xxx/yyy/zzz"); # 上のルーチンを呼びだし
# たぶん"xxx/yyy/zzz"ディレクトリでなんか処理をして
chdir $basedir; # 元のディレクトリに戻る

MacPerlのTips　▲ページトップ　▲▲HTMLに役立つヒント

●chdir

　カレントディレクトリから移動するとき、「chdir "aaa:bbb:";」ではうまくいかない。頭に「:」が必要である。「chdir ":aaa:bbb:";」となる。はまったんでメモしておきます。

●クリップボードの中を取得する

　MacPerl単体ではできないようです。が、スクリプトの中からAppleScriptを呼び出すと取得できます。MacPerlからAppleScriptを呼び出す例になってます。ちゃんとperl側で結果を受けとることもできます。

●CPANからモジュールをインストールする。 for MacPerl 5.6

1. CPANで元ファイルをダウンロードしてきます。
2. 「xxx.tar.zip」ファイルを「MacPerl/Droplets/installme」にドロップします。解凍してはいけません。
3. コンバートするか聞かれるので「yes」をクリックします。これで無事にインストールできるはず。

●MacPerlドロップレットとして保存するアップルスクリプト

　MacPerlでドロップレットを作るとき、デバッグのために何度もスクリプトをDropletとして保存し直さなくてはいけません。で、ドラッグアンドドロップでスクリプト（テキスト）をMacPerlドロップレットとして保存し直してくれるAppleScript。ドロップレットとして保存して使います。

--ドロップしたテキストファイルをMacPerlドロップレットとして保存する。
--名前は「オリジナル名+.dp」となる。
--同名のファイルがあると上書き保存される。
on open DropList
repeat with obj in DropList
set thisname to (alias obj as text) & ".dp"
tell application "MacPerl"
activate
Open obj --開く
Save document 1 in file thisname as Droplet
Close document 1
end tell
end repeat
activate
beep 1 --終わったら合図。
--display dialog "ドロップレット作成終了" --ダイアログで報告がほしければ行頭の--を削除
end open

リンク　▲ページトップ　▲▲HTMLに役立つヒント

　perlスクリプトでよく参考にするページ。

●perlメモ　排他ロック、改行コード、CSV関係など豊富。
●おきらくＰｅｒｌプログラミング入門　正規表現など。TOP「M.Hiroi's Home Page」
●perlプログラミングTips　満載。変換編ではメールアドレスを名前とホストに分けるルーチンとか、10進数を変換したりするなど、ちょっとしたことだけど役に立つものがたっぷり。TOP「ASH multimedia lab」
●Perlメモ/Tips - Perlに関するTipsを掲載しているWebページへのリンク。　あちこちのためになるperlの小技にリンクしています。TOP「Digitian's Home Top」
●Perl表技集　いろいろな技がたっぷり。モジュールの使い方の勉強にもなります。TOP「MASのページ」

ホーム ＞HTMLに役立つヒント＞perlのいろんなルーチン入れ