package plibs;
;######################################################################
;#
;# pLibs version 0.1.17（開発版）
;# CGI/Perlライブラリ
;# Copyright (C) 2000-2003 Kiyoteru Onishi <info@kiyoproject.com>
;# URL http://www.kiyoproject.com/
;; $rcsid = q$Id: plibs.pl,v 0.1.17 2003/03/24 10:11:20 kiyo Exp $;
;#
;######################################################################
;#
;# ■使用許諾
;# 本ソフトウェアはフリーソフトです。個人使用、業務使用に関わらず、以下
;# の条件を満たす限りにおいてソースの改良、および再配布してかまいません。
;#
;# 1. 上記著作権表示、下記免責事項を必ず含めてください。
;#
;# 2. 再配布は、入手したファイルを全て含めた形で行ってください。
;#
;# 3. 変更バージョンは、変更バージョンであることを明示してください。
;#
;# 4. 変更を行った者は、それが誰であるかを明示し、変更日を明確にして
;#    ください。
;#
;# 本ソフトウェアは KIYO Project によって"現状のまま"提供されるものと
;# します。通常そなえるべき品質をそなえているとの保証も、特定の目的に
;# 適合するとの保証を含め、いかなる保証もなされません。本ソフトウェア
;# 使用による、損害発生の原因いかんを問わず、KIYO Project は責任を一切
;# 負いません。
;#
;# ■ファイル配置
;# public_html -- cgi-bin
;#                   |
;#                   |-- lib
;#                        |
;#                        |-- pllibs.pl
;#
;# ■パーミッション
;# ----------------------------------------------------------------
;# ファイル名             アクセス権
;# ----------------------------------------------------------------
;# lib                      755（ディレクトリ）
;# plibs.pl                 644（ライブラリ）
;# ----------------------------------------------------------------
;#
;# ■開発者・協力者リスト
;# ----------------------------------------------------------------
;# 大西清輝 <info@kiyoproject.com>
;# 本ライブラリのオリジナル開発者です。
;# ----------------------------------------------------------------
;# ひまっち
;# nontag関数のバグ報告で協力していただきました。
;# ----------------------------------------------------------------
;#
;######################################################################
;#
;# ■使用例
;# ----------------------------------------------------------------
;# chomp
;# ----------------------------------------------------------------
;# 文字列内の改行コードを削除します。
;#
;#	$str = "hoge\n";	# 変換対象文字列
;#	&plibs'chomp(*str);
;#
;# ----------------------------------------------------------------
;# tobr
;# ----------------------------------------------------------------
;# 文字列内の改行コードをHTMLの<BR>タグに変換します。
;#
;#	$str = "hoge\n";	# 変換対象文字列
;#	&plibs'tobr(*str);
;#
;# ----------------------------------------------------------------
;# trim
;# ----------------------------------------------------------------
;# 文字列前後のスペースを削除します。
;#
;#	$str = "   ho ge   ";	# 変換対象文字列
;#	&plibs'trim(*str);
;#	print "$str\n";	# 文字列 "ho ge" に変換
;#
;# ----------------------------------------------------------------
;# mklink
;# ----------------------------------------------------------------
;# 名前とアドレスからHTMLのリンクを作成します。
;#
;#	$name = '大西清輝';
;#	$addr = 'info@kiyoproject.com';
;#	$ret = &plibs'mklink($name, $addr);
;#	print "$ret\n";
;#
;# ----------------------------------------------------------------
;# lock
;# ----------------------------------------------------------------
;# ファイルロックを開始します。
;# symlink関数がサポートされていない環境（Windows）では、$modに "2"
;# を指定して、open関数を使用するようにしてください。
;#
;#	$file = 'lockfile.lock';	# ロックファイル名
;#	$mod = 2;	# (0=no 1=symlink関数 2=open関数）
;#	&plibs'lock($file, $mod);	# ファイルロック開始
;#	open(FILE, ">>hoge.txt");
;#	print FILE "hogehoge\n";
;#	close(FILE);
;#	&plibs'unlock($file);		# ファイルロック解除
;#
;# ----------------------------------------------------------------
;# unlock
;# ----------------------------------------------------------------
;# ファイルロックを解除します。
;#
;#	$file = 'lockfile.lock';	# ロックファイル名
;#	&plibs'unlock($file);
;#
;# ----------------------------------------------------------------
;# cgierror
;# ----------------------------------------------------------------
;# エラー時にメッセージを表示して、プログラムを終了します。
;#
;#	$title = 'CGIエラー';	# タイトル
;#	# メッセージ内容
;#	$msg = 'ファイルの書き込みに失敗しました。';
;#	open(FILE, ">hoge.txt") || &plibs'cgierror($title, $msg);
;#	print FILE "hogehoge\n";
;#	close(FILE);
;#
;# ----------------------------------------------------------------
;# decode
;# ----------------------------------------------------------------
;# HTMLフォームデータをデコードします。与えられた型グロブ名と同じ
;# 名前のハッシュに、変換後の値を格納します。
;#
;#	&plibs'decode(*in);	# デコード処理
;#	$user   = $in{'name'};
;#	$passwd = $in{'passwd'};
;#
;# ----------------------------------------------------------------
;# imoji
;# ----------------------------------------------------------------
;# NTT DoCoMo i-mode対応絵文字を &#xxxxx; 形式の文字列に変換し、
;# 通常のShiftJIS文字列として利用できるようにします。
;# このサブルーチンは橋本和明氏の著書「大人のCGIスクリプト」
;# （白夜書房刊）に掲載されていた「mojinazo」ルーチンをほぼそのまま
;# 引用させてもらいました。したがって、このサブルーチンの著作権は
;# 橋本氏に帰属します。
;# ただし、本ライブラリを使用して不具合が有ったからといって、橋本氏
;# に文句を付けるは御門違いですので、そこの所ご理解願います。
;# 最後に、有意義なソースコードを広く一般に公開して下さった、橋本氏
;# に心より感謝いたします。
;# Copyright (C) 2001 Kazuaki Hashimoto
;#
;#	&plibs'imoji(*str);
;#	print "$str";	# 変換後文字列
;#
;# ----------------------------------------------------------------
;# ketaiax
;# ----------------------------------------------------------------
;# 利用者が携帯電話からアクセスしてきたかどうかを判定します。
;# i-mode：1  J-SKY：2  EZweb：3  その他：0
;#
;#	$ax = &plibs'ketaiax;
;#	if ($ax == 1) { print "i-mode\n"; }
;#	elsif ($ax == 2) { print "J-SKY\n"; }
;#	elsif ($ax == 3) { print "EZweb\n"; }
;#	else { print "PC\n"; }
;#
;# ----------------------------------------------------------------
;# deny
;# ----------------------------------------------------------------
;# 特定ホストからのアクセスを拒否します。
;# 
;#	# アクセス拒否対象ホスト名を指定する
;#	@deny = ('ppp*.xxx.yyy.com', 'cache.xxx.net');
;#	&plibs'deny(@deny);
;#
;# ----------------------------------------------------------------
;# getaddr
;# ----------------------------------------------------------------
;# ホスト名からIPアドレスを取得します。
;# IPアドレスの取得に失敗した場合は、ホスト名をそのまま返します。
;#
;#	$addr = &plibs'getaddr('www.kiyoproject.com');
;#	print "IPアドレス:$addr\n";
;#
;# ----------------------------------------------------------------
;# gethost
;# ----------------------------------------------------------------
;# IPアドレスからホスト名を取得します。
;# ホスト名の取得に失敗した場合は、IPアドレスをそのまま返します。
;#
;#	$host = &plibs'gethost('133.130.12.172');
;#	print "ホスト名:$host\n";
;#
;# ----------------------------------------------------------------
;# wordcheck
;# ----------------------------------------------------------------
;# 掲示板などで、書き込まれたくない文字列が有るかをチェックします。
;# 対象文字列が存在した場合、その文字列を返します。
;#
;#	$str   = '死ね死ね団';	# チェック対象文字列
;#	@words = ('死ね','援助交際');	# 禁止ワード
;#	$word = &plibs'wordcheck($str, @words);
;#	if ($word ne '') {
;#		&plibs'cgierror('入力エラー',
;#		"禁止ワード「$word」が使用されています。");
;#	} # この例の場合、「死ね」という文字列が返ります。
;#
;######################################################################

$version = undef;
$version = $rcsid =~ /,v ([\d.]+)/ ? $1 : 'unkown';

;####################
;# 改行コードの削除 #
;####################
sub chomp {
	local(*_) = shift;
	s/\r?\n//g; s/\r//g;
	$_;
}

;##########################
;# 改行コード -> <br>タグ #
;##########################
sub tobr {
	local(*_) = shift;
	s/\r?\n/\r/g; s/\r/<br>/g;
	$_;
}

;########################
;# HTMLタグを無効にする #
;########################
sub nontag {
	local(*_) = shift;
	s/&/&amp;/g; s/"/&quot;/g;
	s/</&lt;/g;  s/>/&gt;/g;
	$s;
}

;########################
;# HTMLタグを有効にする #
;########################
sub gettag {
	local(*_) = shift;
	s/&amp;/&/g;  s/&#38;/&/g;
	s/&quot;/"/g; s/&#34;/"/g;
	s/&yen;/\\/g; s/&#165;/\\/g;
	s/&lt;/</g;   s/&#60;/</g;
	s/&gt;/>/g;   s/&#62;/>/g;
	$s;
}

;################################
;# 文字列前後の空白をすべて削除 #
;################################
sub trim {
	local(*s) = shift;
	&ltrim(*s); &rtrim(*s);
	$s;
}

;################################
;# 文字列先頭の空白をすべて削除 #
;################################
sub ltrim {
	local(*_) = shift;
	s/^\s+//;
	$_;
}

;################################
;# 文字列後続の空白をすべて削除 #
;################################
sub rtrim {
	local(*_) = shift;
	s/\s+$//;
	$_;
}

;##################################
;# 名前とアドレスからリンクを作成 #
;##################################
sub mklink {
	local($_, $addr) = @_;
	&chomp(*_); &chomp(*addr); &nontag(*_);
	&trim(*addr);
	if ($addr eq '') {
		return $_;
	} else {
		unless ($addr =~ /^http:|^https:|^ftp:|^mailto:/) {
			$addr = "mailto:$addr";
		}
		return qq|<a href="$addr">$_</a>|;
	}
}

;##########################
;# ファイルロック開始処理 #
;##########################
sub lock {
	local($_, $mod) = @_;
	if ($mod == 1) { &_lock($_); }
	elsif ($mod == 2) { &__lock($_); }
}

;####################################
;# ロックファイル作成 : symlink関数 #
;####################################
sub _lock {
	local($_) = shift;
	local($retry) = 10;
	while (!symlink(".", $_)) {
		if (--$retry <= 0) {
			&cgierror("Error : $!",
				'現在処理が立て込んでいます。<br>しばらくして、もう一度実行してください。','','lock',$_);
		}
		sleep(1);
	}
}

;#################################
;# ロックファイル作成 : open関数 #
;#################################
sub __lock {
	local($s) = shift;
	local($flag) = 0;
	foreach (1 .. 10) {
		unless (-e $s) {
			open(LOCK,">$s") || &cgierror("Error : $!",'ロックファイルの作成に失敗しました。','','lock',$s);
			close(LOCK);
			$flag = 1;
			last;
		} else {
			sleep(1);
		}
	}
	if ($flag == 0) {
		&cgierror("Error : $!",
			'現在処理が立て込んでいます。<br>しばらくして、もう一度実行してください。','','lock',$s);
	}
}

;##########################
;# ファイルロック解除処理 #
;##########################
sub unlock {
	local($_) = shift;
	if (-e $_) { unlink($_); }
}

;#################
;# CGIエラー処理 #
;#################
sub cgierror {
	local(@msg) = @_;
	local($warn) = $^W;
	$^W = 0;
	if (($msg[3] eq 'lock') && (-e $msg[4])) { unlink($msg[4]); }
	&header($msg[0]);
	print <<"EOD";
<body><center><hr><P><h3>$msg[0]</h3>
<P><font color="#ff0000"><B>$msg[1]</B></font>
EOD
	if ($msg[2] ne '') {
		print qq|<P>[<a href="$msg[2]">戻る</a>]\n|;
	}
	print "<P><hr></center>\n";
	&end_html;
	$^W = $warn;
	exit;
}

;############################
;# HTML文章のヘッダ書き出し #
;############################
sub header {
	local($s, $charset) = @_;
	local($warn) = $^W;
	$^W = 0;
	print <<"EOD";
Content-type: text/html

<html><head>
EOD
	if ($charset ne '') {
		print qq|<META HTTP-EQUIV="Content-type" CONTENT="text/html; charset=$charset">\n|;
	}
	print "<title>$s</title></head>\n";
	$^W = $warn;
}

;##########################
;# HTML文章のタグを閉じる #
;##########################
sub end_html {
	print "</body></html>\n";
}

;################################
;# フォームデータのデコード処理 #
;################################
sub decode {
	local(*s, $max) = @_;
	local(@pairs, $pair, $buffer, $name, $value);
	local($warn) = $^W;
	$^W = 0;
	if ($max eq '') { $max = 131072; }
	if ($ENV{'REQUEST_METHOD'} eq 'POST') {
		if ($ENV{'CONTENT_LENGTH'} > $max) {
			&cgierror('Overflow','入力文字数が多すぎます。');
		}
		read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
	} else { $buffer = $ENV{'QUERY_STRING'}; }
	@pairs = split(/&/, $buffer);
	foreach $pair (@pairs) {
		($name, $value) = split(/=/, $pair);
		$value =~ tr/+/ /;
		$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
		$s{$name} = $value;
	}
	$^W = $warn;
}

;##################################
;# i-mode対応絵文字を文字列に変換 #
;##################################
sub imoji {
	local(*s) = shift;
	local($count) = 0;
	local($wk2) = '';
	local($wk1, $max);
	local(@in);
	$max = length($s);
	while ($count ne $max){
		$in[0] = substr($s, $count, 1);
		if ($in[0] =~ /[\x81-\x9f\xe0-\xfc]/) {
			$count++;
			$in[1] = substr($s, $count, 1);
			$wk1 = "$in[0]$in[1]";
			if ($in[0] =~ /[\xf8]/) {
				if ($in[1] =~ /[\x9f-\xff]/) {
					$wk1 = ord($in[0])*256+ord($in[1]);
					$wk1 = "&#$wk1;";
				}
			} elsif ($in[0] =~ /[\xf9]/) {
				if ($in[1] =~ /[\x40-\xaf]/) {
					$wk1 = ord($in[0])*256+ord($in[1]);
					$wk1 = "&#$wk1;";
				}
			}
		} else {
			if ($in[0] =~ /\xa0-\xdf]/) {
				$wk1 = $in[0];
			} else {
				$wk1 = $in[0];
			}
		}
		$wk2 = "$wk2$wk1";
		$count++;
	}
	$s = $wk2;
	$s;
}

;##############################
;# 携帯電話からのアクセス判定 #
;##############################
sub ketaiax {
	local($s) = $ENV{'HTTP_USER_AGENT'};
	$s = &_ketaiax($s);
	$s;
}

;##############################
;# 携帯電話からのアクセス判定 #
;##############################
sub _ketaiax {
	local($_) = shift;
	local($imode) = (/^DoCoMo/);
	local($jsky) = (/^J-PHONE/);
	local($ez) = (/UP(\.Browser)|(Sim)/);
	if ($imode) { return 1; }
	elsif ($jsky) { return 2; }
	elsif ($ez) { return 3; }
	else { return 0; }
}

;################################
;# 特定ホストからのアクセス拒否 #
;################################
sub deny {
	local(@deny) = shift;
	local($addr) = $ENV{'REMOTE_ADDR'};
	local($host) = $ENV{'REMOTE_HOST'};
	local($match) = 0;
	local($s);
	$host = &_gethost($addr, $host);
	foreach $s (@deny) {
		if ($s eq '') { next; }
		$s =~ s/\*/\.\*/g;
		if ($host =~ /$s/) { $match = 1; last; }
	}
	if ($match) {
		&cgierror('Access Error','サーバーへのアクセスに失敗しました。');
	}
}

;################################
;# ホスト名からIPアドレスを取得 #
;################################
sub getaddr {
	local($host) = shift;
	local($addr);
	&chomp(*host); &trim(*host);
	$addr = (gethostbyname($host))[4];
	if ($addr ne '') {
		$addr = sprintf("%u.%u.%u.%u", unpack("C*", $addr));
	} else { $addr = $host; }
	$addr;
}

;################################
;# IPアドレスからホスト名を取得 #
;################################
sub gethost {
	local($addr) = shift;
	local($s);
	$s = &_gethost($addr, '');
	$s;
}

;##################
;# ホスト名の取得 #
;##################
sub _gethost {
	local($addr, $host) = @_;
	&chomp(*addr); &chomp(*host);
	&trim(*addr); &trim(*host);
	if (($host eq '') || ($host eq $addr)) {
		$host = gethostbyaddr(pack('C4',split(/\./,$addr)), 2) || $addr;
	}
	$host;
}

;##################
;# ワードチェック #
;##################
sub wordcheck {
	local($s) = shift;
	local($match) = '';
	local($word);
	foreach $word (@_) {
		if (index($s, $word) >= 0) { $match = $word; last; }
	}
	$match;
}

;##################
;# ファイルコピー #
;##################
sub copy {
	local($in, $out) = @_;
	local(@buf);
	open(IN, "<$in") || return 0;
	binmode(IN);
	@buf = <IN>;
	close(IN);
	open(OUT, ">$out") || return 0;
	binmode(OUT);
	print OUT @buf;
	close(OUT);
	return 1;
}

1;