package Query;
#
#  Query.pm
#    CGI への入力データを扱う
#

use strict;
use vars qw($VERSION);

#$VERSION = '1.1.1'; # 2004-04-15
$VERSION = '1.1.2'; # 2008-01-14


#
# 基本設定
#   getable    .. 1 以上なら，QUERY_STRING を分解して保持する。デフォルトは1。
#   postable   .. 1 以上なら，request-method が POST の時に
#                 STDIN からクエリ文字列を読み込む。デフォルトは1。
#
#   uploadable .. 1 以上なら，request-method が POST の時に
#                 multipart/form-data なクエリを読み込む。デフォルトは0。
#                 1 以上を指定する場合，アップロード可能なサイズをバイト単位で指定。
#
#                 input 要素 name 属性の文字列とファイルサイズを対応させた
#                 ハッシュへのリファレンスを渡すと，アップロード可能な
#                 ファイルサイズを制限できる。
#                      uploadable => {
#                        file1 => 1024 * 1024,
#                        file2 => 2048 * 1024
#                      }
#                 file1 は 1MiBytes，file2 は 2MiBytesまで保存される。
#                 他の名前でファイルがアップロードされると，保存されない。
#
#   no_binmode .. STDIN に対して binmode() を実行しない。
#                 これは，定義するだけで有効となる。
#                 デフォルトは未定義。
#
#   require_list .. name 属性のリストのリファレンスを与えると，
#                   それらの get() 時に必ずリストのリファレンスが返る事を
#                   保証する。
#
#  (次の設定は uploadable が 1 以上の場合に使用される) 
#   directory  .. 一時ファイル置き場のディレクトリ名
#   dir_perm   ..     そのパーミッション (自動生成した場合に設定)
#   file_perm  .. 一時ファイル置き場にファイルを生成した場合のパーミッション
#
#   filename   .. 定義しなかった場合，デフォルトの設定が使われる
#     >>  スカラ値をセットした場合
#           "<directory>/<filename>" のような値がファイル名として使用される。
#     >>  サブルーチンへのリファレンスの場合
#             第1引数に input name=".." に設定した値
#             第2引数にアップロード時のファイル名(あれば)
#             第3引数に mime-type (あれば)
#           として実行される。
#           返された文字列はそのまま open OUT '>'.$RESULT; が実行される。
#     >>  ハッシュへのリファレンスの場合
#           input name=".." に設定した値と，保存したいファイル名を関連付ける。
#   file_perm  .. 保存したファイルのパーミッション
#
#   no_change_ext .. デフォルトのファイル名生成ルーチンを使う場合，
#                    アップロードされたファイルの拡張子 cgi を txt に変換しない。
#                    これは，定義するだけで有効となる。
#                    デフォルトでは未定義。
#
#   no_interrupt  .. uploadable のサイズ制限に到達しても，STDIN からの
#                    読み込みは続ける。
#                    is_interrupted() は 0 を返す。
#                    定義するだけで有効となる。
#                    デフォルトでは未定義。
#
#   no_unlink_limited_file .. uploadable のサイズ制限に到達し，中途半端に
#                    記録されたファイルを削除 *しない* ようにする。
#                    定義するだけで有効となる。
#                    デフォルトでは未定義で，中途半端に記録されたファイルは
#                    自動で削除するようになっている。
#
my %_pref = (
	getable => 1,
	postable => 1,
	uploadable => 0,
	directory => '.',
	dir_perm => 0666,
	file_perm => 0666,
);



my %_the_data = ();  # ここにデータがある

my $_is_interrupted = 0;  # サイズ制限に引っかかって，処理を中断したか？

#------------------------------------------------------------------------------
# データを得る
#  ヒント：
#   $d = query::get('key');
#    if (ref $d eq 'HASH') {
#       # ハッシュの場合，ファイルとしてアップロードされたもの
#       print $d->{'original'};  # アップロード時のファイル名
#       print $d->{'CONTENT_TYPE'};  # Content-Type
#       if ( open FILE, $d->{'path'} ) {  # 格納されているパス
#          ...
#       }
#    }
#    elsif (ref $d eq 'ARRAY') {
#       # 同名のinput要素が複数あった場合，
#       # リストとして格納されている
#       if (ref $d->[0] eq 'HASH') {
#          # さらにこれがハッシュだった場合，ファイルとしてアップロードされたもの
#          print $d->[0]{'original'};
#          ...
#       } else {
#          # そうでなければ，ただのスカラ
#       }
#    }
#    else {
#       # ただのスカラ
#    }
#
#
sub get {
	return
		defined $_[0] && exists $_the_data{$_[0]} ? $_the_data{$_[0]} :
		defined $_[1] ? $_[1] :
			undef;
}


#------------------------------------------------------------------------------
#  入力項目がファイルである物の path を得るショートカット
sub get_path {
	my $key = $_[0];
	my $idx = $_[1] || 0;

	if (ref $_the_data{$key} eq 'HASH')
	{
		return $_the_data{$key}->{'path'};
	}

	if (ref $_the_data{$key} eq 'ARRAY' &&
	    $idx < scalar (@{$_the_data{$key}}) &&
	    ref $_the_data{$key}[$idx] eq 'HASH')
	{
		return $_the_data{$key}[$idx]{'path'};
	}

	return undef;
}


#------------------------------------------------------------------------------
#  use query;  で呼び出されるルーチン
#
# 注意：デフォルトの設定では STDIN はバイナリモードとなる
#
sub import {
	my $package_name = shift;  # このパッケージ名
	&startup(@_);
}


#------------------------------------------------------------------------------
#  use query(); としてあえて import を実行しなかったなら
#   startup を使えばよい
#
# 注意：デフォルトの設定では STDIN はバイナリモードとなる
#
sub startup {
	my $reqmethod = uc($main::ENV{'REQUEST_METHOD'});

	# 設定を %_pref にマージする
	if (ref $_[0] eq 'HASH') {
		for (keys %{$_[0]}) {
			$_pref{$_} = _deep_clone($_[0]{$_});
		}
	}

	unless (defined $_pref{'directory'}) { $_pref{'directory'} = '.'; }

	if (exists $_pref{'no_binmode'}) {
		# ok, we do not binmode() for STDIN
	} else {
		binmode(STDIN);
	}

	if ($reqmethod eq 'POST') {	
		# method= post の場合 .. CONTENT_TYPE を見て振り分け
		my $ctype = $main::ENV{'CONTENT_TYPE'};

		if ($ctype =~ m|multipart/form-data\s*;\s*(.*)|) {
			&_startup_post_formdata (&_split_parameter($1))
				if (ref $_pref{'uploadable'} eq 'HASH' || $_pref{'uploadable'} >= 1);
		}
		elsif ($ctype =~ m|application/x-www-form-urlencoded|) {
			&_startup_post_standard() if ($_pref{'postable'} >= 1);
		}

	} else {
		&_startup_get() if ($_pref{'getable'} >= 1);

	}


	# 設定 require_list の処理
	if (exists $_pref{'require_list'} && ref $_pref{'require_list'} eq 'ARRAY') {
		for (@{$_pref{'require_list'}}) {
			if (ref $_the_data{$_} ne 'ARRAY') {
				my $temp = $_the_data{$_};
				$_the_data{$_} = defined $temp ? [$temp] : [];
			}
		}
	}
}


#------------------------------------------------------------------------------
# 構造体をコピー
# my $them = Query::clone()  (引数がない場合)
# @returns  ハッシュへのリファレンス
#
# my $value = Query::clone('name')  (引数がある場合)
# @returns メンバの値のディープコピー。スカラ値か，リストのリファレンスか，
#           ハッシュのリファレンスが返る。
#           メンバが存在しない場合，undef が返る。
sub clone {
	if (defined $_[0]) {
		if (ref $_[0] eq '' && defined $_the_data{$_[0]}) {
			return &_deep_clone($_the_data{$_[0]});
		} else {
			return undef;
		}
	}

	return &_deep_clone(\%_the_data);
}


#------------------------------------------------------------------------------
# キー(と値)を列挙する
sub begin_enum {
	scalar(keys %_the_data); # イテレータリセット
	my ($k, $v) = each %_the_data;
	return wantarray ? ($k, $v) : $k;
}

# 列挙
sub get_next {
	my ($k, $v) = each %_the_data;
	return wantarray ? ($k, $v) : $k;
}


#------------------------------------------------------------------------------
# デフォルトのファイル名生成アルゴリズム
# @param[0]  input 要素 name 属性の値
# @param[1]  リクエスト内の filename=".*" の値
# @param[2]  リクエスト内の content-type の値
# @returns   ファイル名
sub create_filename {
	# 拡張子を決定
	my $ext = '.dat';
	if ($_[1] =~ /(\.\w+)$/) {
		$ext = $1;
		unless (exists $_pref{'no_change_ext'}) {
			$ext = '.txt' if (uc($ext) eq '.CGI');
			$ext = '.txt' if (uc($ext) eq '.BAT');
			$ext = '.dat' if (uc($ext) eq '.EXE');
		}
	}

	# 使用可能なファイル名を探す
	my $filename = '';
	my $seq = 0;

	$filename = sprintf ("%010d%02d%s", time(), $seq++, $ext);
	while (-f "$_pref{'directory'}/$filename") {
		if ($seq == 100) {
			$seq = 0;
			sleep(1);
		}
		$filename = sprintf ("%010d%02d%s", time(), $seq++, $ext);
	}  # ファイルが既に存在している間，繰り返し

	return $filename;
}



#------------------------------------------------------------------------------
#  サイズ制限により，処理を中断したか？
#       -- この場合，入力された全ての値を保持しているとは限らない

sub is_interrupted { $_is_interrupted; }



###############################################################################
#
#         以下，private なメソッド


#------------------------------------------------------------------------------
#  構造体のディープコピー
sub _deep_clone {
	local $_;
	my $src = shift;

	if (ref $src eq 'HASH') {
		my %result = ();
		for (keys %$src) {
			$result{$_} = ref $src->{$_} ? &_deep_clone($src->{$_}) : $src->{$_};
		}
		return \%result;
	}
	elsif (ref $src eq 'ARRAY') {
		my @result = ();
		for ( @{$src} ) {
			push @result, ref $_ ? &_deep_clone($_) : $_;
		}
		return \@result;
	}
	elsif (ref $src eq 'SCALAR') {
		my $result = $$src;
		return \$result;
	}
	# else
	return $src;
}


#------------------------------------------------------------------------------
#
#  a=b; cdef; g  .. のような文字列を ; で分解，余分な空白を削除
#
sub _split_parameter {
	return map { s/^\s+//;  s/\s+$//;  $_; } split /;/, $_[0];
}


#------------------------------------------------------------------------------
# CRLF もしくは (あまり推奨されないが) LF を改行とみなす
# LFCR や CR は改行としない
my $stock__ = '';
my $end_of_post__ = 0;
sub UNIT_SIZE { 2000; }  # だいたいこれくらいを目安に読んだりする
my $boundary__ = '';

sub _read_line {

	do {
		if ($stock__ =~ /^([^\r]*?)\n/ ||
		    $stock__ =~ /^(.*?)\r\n/)
		{
			my $line = $1;
			$stock__ = $';  #'
			return $line;
		}

		my $buf;
		if (read(STDIN, $buf, UNIT_SIZE) > 0) {
			$stock__ .= $buf;
		} else {
			$end_of_post__ = 1;
		}

	} until ($end_of_post__);

	my $tail = $stock__;
	$stock__ = '';
	return $tail;
}


#------------------------------------------------------------------------------
#  UNIT_SIZE 前後か，もしくは crlf{boundary} まで読む
#  crlf{boundary} はストリームに残るため，_read_line で読み出すべき
sub _read_data {

	# 少なくとも crlf {boundary} '--' 相当量が格納されるまで読む
	my $to_read_size = UNIT_SIZE + length($boundary__) + 4 - length($stock__);
	if ($to_read_size > 0) {
		my $buf;
		my $r = read(STDIN, $buf, $to_read_size);
		if ($r <= 0) {
			$end_of_post__ = 1;
		} else {
			$stock__ .= $buf;
		}
	}

	# crlf にマッチする？ -> その前を返す。crlf{boundary} は残す
	if ($stock__ =~ /\r\n\Q$boundary__/o) {
		$stock__ = substr($stock__, length($`));
		return $`;
	}

	# 今回マッチしなかったし，次の 1バイトもありえない
	if ($end_of_post__) {
		my $result = $stock__;
		$stock__ = '';
		return $result;
	}

	# 今回はマッチしなかったが，次に 1バイトを付加する事で
	# crlf{$boundary} がマッチするかもしれない
	# 2 + length($boundary) - 1 ... -1 の分は，次に1バイト付加する部分
	my $result_len = length($stock__) - (2 + length($boundary__) - 1);
	if ($result_len > 0) {
		my $result_str = substr($stock__, 0, $result_len);
		$stock__ = substr($stock__, $result_len);
		return $result_str;
	}
	return '';
}


#------------------------------------------------------------------------------
# request-method = POST で
#  Content-Type: multipart/form-data の場合
sub _startup_post_formdata {
	my @params = @_;  # multipart/form-data; 以下のパラメータ
	my $more = 0;

	# boundary 文字列を得る
	for (@params) {
		if (/^boundary=(.*)/) {
			$boundary__ = '--'.$1;
		}
	}

	my $line = &_read_line();  # 最初のboundary文字列を消費
	if ($line ne $boundary__) {
		&_error_stop();
	}

	do {
		# ヘッダ部分を処理
		my $type = 0;  # Content-Type が記述されていれば 1 .. ファイルに格納するもの
		my $input_name = '';
		my $original = '';
		my $content_type = '';

		do {
			$line = &_read_line();
			if ($line =~ m|Content-Disposition\s*:\s*|i) {
				for (&_split_parameter($')) {  #'
					if (/^name\s*=\s*"(.*)"/ || /^name\s*=\s*'(.*)'/ || /^name\s*=(.+)/) {
						$input_name = $1;
					} elsif (/^filename\s*=\s*"(.*)"/ || /^filename\s*=\s*'(.*)'/ ||
					         /^filename\s*=([\S]+)/)
					{
						$original = $1;
					}
				}
			}
			elsif ($line =~ m|Content-Type\s*:\s*|i) {
				$type = 1;
				$content_type = $';  #'
			}

		} while (length($line) > 2);

		# コンテンツの部分を処理
		if ($type == 0) {
			&_startup_post_formdata_input($input_name);
		} else {
			&_startup_post_formdata_file($input_name, $original, $content_type);
		}

		if ($_is_interrupted) {
			# サイズ制限に引っかかったため，処理を中断
			return;
		}

		# この時点でストリームには少なくとも crlf と boundary があるはず
		$line = &_read_line();
		if (length($line) != 0) {  # 空行が得られるはず
			&_error_stop();
		}

		$line = &_read_line();   # boundary (とcrlf) が得られるはず
		if ($line =~ /^\Q$boundary__--/o) {  # これが最後だった
			$more = 0;
		} elsif ($line eq $boundary__) {  # 次のバウンダリへ
			$more = 1;
		} else {
			&_error_stop();  # 何これ...
		}

	} while ($more);
}


#------------------------------------------------------------------------------
# method= POST
# content-type: multipart/form-data で
#  通常のinputコントロールの場合
sub _startup_post_formdata_input {
	my $data = '';
	my $buf;
	do {
		$buf = &_read_data();
		$data .= $buf;
	} while (length($buf) > 0);

	&_map_data($_[0], $data);
}


#------------------------------------------------------------------------------
# _startup_post_formdata_file()
# method= POST
# content-type: multipart/form-data で
#   Content-type が示されていた場合 .. ファイルとして格納

sub _requre_directory {
	# ディレクトリがなければ生成
	unless (-d $_pref{'directory'}) {
		my $perm = 0666;
		if (defined $_pref{'dir_perm'} && $_pref{'dir_perm'} > 0) {
			$perm = $_pref{'dir_perm'};
		}
		unless (mkdir $_pref{'directory'}, $perm) {
			&_error_stop('mkdir() failed');
		}
	}
	1;
}

sub _startup_post_formdata_file {
	my $input_name = shift;
	my $original = shift;
	my $content_type = shift;

	# upload サイズ制限
	my $up_limit = 0;
	if (ref $_pref{'uploadable'} eq 'HASH' &&
	    defined $_pref{'uploadable'}{$input_name})
	{
		# name毎に制限をかけている
		$up_limit = $_pref{'uploadable'}{$input_name} - 0;
	}
	elsif (ref $_pref{'uploadable'} eq '')
	{
		$up_limit = $_pref{'uploadable'} - 0;
	}
	else
	{
		# なんだか分からないものがセットされているか，
		# 知らない name 属性の値でアップロードされた
	}

	my $filename = &_make_filename($input_name, $original, $content_type);
	my $path = $_pref{'directory'}. '/'. $filename;

	# 書き込み用にファイルを開けるか？

	my $you_can = 0;
	my $errmsg = 'WARN: not open file at _startup_post_formdata_file()';

	if ($up_limit <= 0) {
		&_error_continue( "$errmsg: size is limited");

	} elsif (length($path) <= 1) {
		&_error_continue( "$errmsg: no path specified");

	} elsif ((not defined $filename) || length($filename) <= 0) {
		&_error_continue( "$errmsg: no filename specified");

	} elsif ((not defined $original) || length($original) <= 0) {
		# これはよく起こる。
		# この場合，ファイルの実体は送られて来てはいない。
		&_error_continue( "$errmsg: no original-file-name");

	} elsif (! _requre_directory()) {
		&_error_continue( "$errmsg: directory not exists.");

	} elsif (! open OUT, '>'.$path) {
		&_error_continue( "$errmsg: file could not open.");

	} else {
		binmode(OUT);
		$you_can = 1;
	}

	# read_data は，バウンダリが登場する直前まで入力を読み込む
	my $buf = &_read_data();
	my $complete = 1; # 全て書き込みが成功する事を仮定

	while (defined $buf && length($buf) > 0 ) {
		# 制限に引っかかれば，中断
		if ((not defined $_pref{'no_interrupt'}) &&
		    $up_limit <= 0)
		{
			_log("interrupted.");
			$_is_interrupted = 1;
			$complete = 0;
			last;
		}

		# 書き込みたいバッファのサイズ = 読み込めたバッファのサイズ
		my $to_write = length($buf);

		# 制限に届きそうなら，制限の範囲内にする
		if ($up_limit < $to_write) {
			$to_write = $up_limit;
			$complete = 0;
		}

		# ファイルに (書き込めるなら) 書き込み
		my $wrote = $to_write;
		if ($you_can && $to_write > 0) {
			$wrote = syswrite(OUT, $buf, $to_write);
			if (not defined $wrote) { die 'syswrite() error.'; }
		}

		# 制限の値を減少
		$up_limit -= $wrote if ($wrote > 0);
				# バグに注意：
				# if (...  がなければ，$wrote がマイナスの場合に $up_limit は増加してしまう

		# 次のバッファを読む
		$buf = &_read_data();
	}

	# 制限値を更新する
	if (ref $_pref{'uploadable'} eq 'HASH' &&
	    defined $_pref{'uploadable'}{$input_name})
	{
		$_pref{'uploadable'}{$input_name} = $up_limit;
	}
	elsif (ref $_pref{'uploadable'} eq '')
	{
		$_pref{'uploadable'} = $up_limit;
	}

	if ($you_can) {
		close OUT;
		if (defined $_pref{'file_perm'} && $_pref{'file_perm'} > 0) {
			chmod($_pref{'file_perm'}, $path);
		}

		if ($complete || defined $_pref{'no_unlink_limited_file'}) {
			&_map_data ($input_name, {
					path => $path,
					directory => $_pref{'directory'},
					filename => $filename,
					original => $original,
					CONTENT_TYPE => $content_type,
					complete => $complete,
				});

		} else {
			unlink $path;
		}
	}
}


#------------------------------------------------------------------------------
# method=POST
#  通常のポスト -- STDIN を分解して urldecode し，マップする
sub _startup_post_standard {
	my $buf;
	read(STDIN, $buf, $main::ENV{'CONTENT_LENGTH'});
	&_decode_and_map($buf);
}


#------------------------------------------------------------------------------
# method=GET
#  通常のGET  -- QUERY_STRING を分解して urldecode し，マップする
sub _startup_get {
	&_decode_and_map($main::ENV{'QUERY_STRING'});
}


#------------------------------------------------------------------------------
# url-encoded をデコードしてマップ
# @param  url-encode された文字列
sub _decode_and_map {
	if (defined $_[0]) {
		for (split /&/, $_[0]) {
			my ($k ,$v) = split /=/;
			$v =~ tr/+/ /;
			$v =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack('C',hex($1))/eg;
			&_map_data($k, $v);
		}
	}
}



#------------------------------------------------------------------------------
# 値をマップ
sub _map_data {
	my ($k, $v) = @_;

	if (ref $_the_data{$k} eq 'ARRAY') {
		push @{$_the_data{$k}}, $v;
	} elsif (defined $_the_data{$k}) {
		my $tmp = $_the_data{$k};
		$_the_data{$k} = [];
		push @{$_the_data{$k}}, $tmp, $v;
	} else {
		$_the_data{$k} = $v;
	}
}

#------------------------------------------------------------------------------
# ファイル名を決定する
#
# @param[0]  input 要素 name 属性の値
# @param[1]  リクエスト内の filename=".*" の値
# @param[2]  リクエスト内の content-type の値
# @returns   ファイル名
sub _make_filename {

	if (exists $_pref{'filename'}) {
		# コードが指定されていれば，コードを実行する
		if (ref $_pref{'filename'} eq 'CODE') {
			return &{$_pref{'filename'}}(@_);
		}
		# ハッシュが指定されていれば，対応する値を返す
		elsif (ref $_pref{'filename'} eq 'HASH') {
			return $_pref{'filename'}{$_[0]};
		}
		# スカラが定義されていれば，そのまま返す
		elsif (ref $_pref{'filename'} eq '') {
			return $_pref{'filename'};
		}
	}


	##### デフォルトの一時ファイル名を生成する
	return &create_filename(@_);
}


sub _log {
	if (0 && open LOG, ">>query_log.dat") {
		binmode(LOG);
		print LOG @_, "\n";
		close LOG;
	}
}


sub _error_stop {
	die $_[0];
}


sub _error_continue {
	&_log(@_);
}

1;

__END__

  Copyright (C) tkuri {at} fat.coara.or.jp. All rights reserved.

   1. 本モジュールの著作権は著者に帰属します。
   2. 本モジュールの使用，再配布，販売について，著者へ問い合わせる事なく
      行えます。
   3. 本モジュールの一部を改変した場合，改変部分の著作権は改変者に帰属します。
   4. 著者は不具合に対処する責任を負わないものとします。
   5. 本モジュール使用者は常に本モジュールの脆弱性に関する情報の収集に努め，
      脆弱性を把握してから 45 日以内に本モジュールを脆弱性の修正された
      バージョンにアップデートするか，使用者の責任において修正するか，
      使用を停止しなければなりません。
   6. 本モジュールが直接的あるいは間接的に引き起こしたいかなる損害も，
      著者は一切の責任を負わないものとします。

 2008-01-14 v1.1.2
   if ($seq = 100) なんてなミスを本当にやらかすとは思わなかった．．．
   しかも4年間も気付かないし．……実害が無かったからだけど :-)
   
 2004-08-09 v1.1.1
   _read_line() 内の正規表現で，行を探すのに最短マッチを使って
   いなかった部分を修正。
   _read_data() の最後，$result_len がマイナスになる可能性を考慮。
   # 今までなぜうまく動いていたのか，少し不思議。:)