#!/usr/local/bin/perl
use CGI;
use GD;
use Digest::MD5;

package TGimpy;
;########################################################################
;#	CAPTCHA Tiny-Gimpy
;#
;#			Programmed by Piroli YUKARINOMIYA <piroli@magicvox.net>
;########################################################################
;# '05/06/01	1.00	初版作成
;########################################################################

;### 私のファイル名を変更した場合は * 必ず * 修正してください
$szMyName = 'mangate.pl';

;### 設定ファイルへのディレクトリパス
sub GetCfgPath { return './spa.cfg'; }



;########################################################################
;# CGI のメインエントリ
&CGIMain () if ($ENV{'SCRIPT_NAME'} =~ m/$szMyName$/);
sub CGIMain {
	my $q = CGI->new;
	my $txt = $q->param ('excerpt');

	my $cfg = $q->param ('cfg');
	$cfg = undef if (! $cfg);
	my $key = $q->param ('key');
	$key = rand () if (! $key);

	OpenConfigFile ($cfg);
	my $ans = GetAnswer ($key);
	$num = $ans;
	CreateImage ($ans);
;##########################
	$ansfile = "anses6.dat";
	open(OUT,">$ansfile") || &error("Write Error: $ansfile");
	flock(OUT,2);
	print OUT $ans;
	flock(DBG,8);
	close(OUT);
;##########################
	exit;
}

;########################################################################
;# 設定ファイルを読み込む
sub OpenConfigFile
{
	my $cfg = shift;

	;# 規定値を定義するが、この値での実行結果に意味はない
	$szCryptKey = 'smiov948tksuhjk';
	$nFigure    = 6;

	;# 不正パス
	return (0) if (! $cfg);
	return (0) if ($cfg =~ m/[^\w]/);
	my $cfg_file = GetCfgPath (). "/${cfg}.cfg";

	;# 設定値をインポート
	eval {
		require $cfg_file;
	};
	return (0) if ($@);

	;# 制限値チェック
	$nFigure = int ($nFigure + 0.5);
	$nFigure = 1 if ($nFigure < 1);
	$nFigure = 9 if (9 < $nFigure);

	return (1);
}

;########################################################################
;# キーに対応した答えを求める
sub GetAnswer
{
	my $key = shift;

	my $md5 = Digest::MD5->new ();
	$md5->add ($key);
	$md5->add ($szCryptKey);

	my $s = 0;	
	my $mod_num = (10 ** $nFigure);
	foreach my $i (split ("", $md5->digest)) {
		$s = ($s * 256 + ord ($i)) % $mod_num;
	}

	return (substr (sprintf ("%09d", $s), 9 - $nFigure));
}

;########################################################################
;# 画像を生成する
sub CreateImage
{
	my $ans = shift;

	;# 規定値
	$nSizeX = 88 if (! $nSizeX || $nSizeX < 0);
	$nSizeY = 15 if (! $nSizeY || $nSizeY < 0);

	my $img = new GD::Image ($nSizeX, $nSizeY);
	if ($img == undef)
	{
		print "Content-type: text/plain\n\n";
		print "fail to create GD::Image object\n";
		return (0);
	}

	;# いくつかの色を確保
	my $colBG = GetColor ($img, "ffffff");
	my $colFG = GetColor ($img, "000000");

	;# 背景を作成
	$img->filledRectangle (0,0, $nSizeX-1,$nSizeY-1, $colBG);
	$img->rectangle (0,0, $nSizeX-1,$nSizeY-1, $colFG);

	;# 文字を描画
	$fx = ($nSizeX - 9 * $nFigure) / 2;
	$fy = ($nSizeY - 15) / 2;
	$img->string (GD::Font->Giant, $fx,$fy    , $ans, $colFG);
	$img->string (GD::Font->Giant, $fx,$fy - 1, $ans, $colFG);

	;# バイナリ・ストリームへ書きこむことを確実にする
	binmode STDOUT;
	;# イメージをPNGに変換し、標準出力に出力
	print "Content-type: image/png\n\n";
	print $img->png;
}

;########################################################################
;# いろいろ小物
sub GetColor
{
	my $img = shift;
	my $rgb = shift;

	;# RRGGBB
	($r, $g, $b) = $rgb =~ /#?([0-9a-fA-F]{2})([0-9a-fA-F]{2})([0-9a-fA-F]{2})/;
	return ($img->colorResolve (hex ($r), hex ($g), hex ($b))) if ($r && $g && $b);
	;# RGB
	($r, $g, $b) = $rgb =~ /#?([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])/;
	return ($img->colorResolve (hex ($r.$r), hex ($g.$g), hex ($b.$b))) if ($r && $g && $b);

	return ($img->colorResolve (0, 0, 0));
}



;########################################################################
;# 答え合わせ
sub CheckAnswer
{
	my $cfg = shift;
	my $key = shift;
	my $ans = shift;

	return (0) if (! OpenConfigFile ($cfg));
	return (0) if (GetAnswer ($key) ne $ans);

	return (1);
}

1;
