package Query;

#### =========================================================== ####
####  Query.pm ---- Decode queries from web form                 ####
####  Copyright(C) 1997-1998 Kawasaki Yuusuke <u-suke@kawa.net>  ####
#### =========================================================== ####

require "jcode.pl";     # 日本語コード変換はやっぱり jcode.pl
use Uni2euc;            # Unicode にも対応できているのかどうか
use Misc;
use Memo;

$VERSION = "0.13";

sub import($){
    # $Each -- multipart/form-data 読み込み時の分割バイト数
    # 巨大なファイルのアップロードにも対応すべく、一度に全ての
    # 入力を読み込まずに、このバイト数毎に分けて読み込みます。
    # Boundary の文字列長よりも長い必要があります。（初期値：128）
    $Each = 128;
    
    # $TempDir -- テンポラリファイルを置くディレクトリ
    $TempDir = ".";
	
	# $MaxSize -- 最大ファイル容量（KB 単位）
	$MaxSize = 0;
}

sub MemoPrint(@){}						# 何もしない関数

#### ----------------------------------------------------------- ####
####  DecodeQuery($) -- フォームからの入力をハッシュとして返す   ####
#### ----------------------------------------------------------- ####

sub DecodeQuery(){
	my( $query );
	$query = new Query();				# オブジェクト取得
	return undef unless $query;			# オブジェクト取得失敗
	$query->Hashes();					# ハッシュを返す
}

#### ----------------------------------------------------------- ####
####  DecodeFields($) -- キーは必ず英大文字とする（ADAMZ 向け）  ####
#### ----------------------------------------------------------- ####

sub DecodeFields(){
	my( $query );
	$query = new Query();				# オブジェクト取得
	return undef unless $query;			# オブジェクト取得失敗
	$query->Upper();					# キー文字中を英大文字に統一
	$query->Nospace();					# キー文字中に空白を入れない
	$query->Hashes();					# ハッシュを返す
}

#### ----------------------------------------------------------- ####
####  DecodeString($) -- x-www-form-urlencoded の展開            ####
#### ----------------------------------------------------------- ####

sub DecodeString($){
    local( $remain ) = @_;
    &jcode::convert( *remain, "euc" );          # 直接日本語を入れた場合
    my( @array, $query, $key, $value );
	my( $no ) = 0;
    foreach $query ( split( /\&/, $remain ) ){
        if( $query =~ /=/ ){
            ( $key, $value ) = ( $`,     $'     );
        }else{
            ( $key, $value ) = ( $query, $query );
        }
        $key =~ s/\+/ /g;
        $key =~ s/%u([0-9A-F][0-9A-F][0-9A-F][0-9A-F])/
                    &Uni2euc::Hex2euc($1)/ieg;  # Unicode 対応（α版）
        $key =~ s/%([0-9A-F][0-9A-F])/pack("c",hex($1))/gei;
        $value =~ s/\+/ /g;
        $value =~ s/%u([0-9A-F][0-9A-F][0-9A-F][0-9A-F])/
                    &Uni2euc::Hex2euc($1)/ieg;  # Unicode 対応（α版）
        $value =~ s/%([0-9A-F][0-9A-F])/pack("c",hex($1))/gei;
        $value =~ s/\n?\r\n?/\n/g;              # 改行コードを揃える
        push( @array, $key, $value );
#       &Memo::Print( "\"$key\" = \"$value\"" );
		$no++;
    }
	&Memo::Print( "$no keys found." );
    @array;
}


#### ----------------------------------------------------------- ####
####  new( $tempdir, $maxsize ) -- 新しいオブジェクト            ####
#### ----------------------------------------------------------- ####

sub new($;$$){
	my( $package ) = shift;
	my( $tempdir, $maxsize ) = @_;
	my( $this );
	$this->{queries} = [];						# 無名配列
	$this->{tempdir} = $tempdir || $TempDir;	# テンポラリディレクトリ
	$this->{maxsize} = $maxsize || $MaxSize;	# 最大ファイル容量
	$this->{decoded} = 0;						# デコード処理は未実施
	$this->{upper}   = 0;						# キー英大文字フィルタ
	$this->{lower}   = 0;						# キー英小文字フィルタ
	$this->{kanji}   = "euc";					# 日本語コードフィルタ
	bless $this;
	$this;
}

#### ----------------------------------------------------------- ####

sub DESTROY($){
	my( $this ) = shift;
	&Memo::Print( "queries destroied" );	# メッセージを表示するだけ
}

#### ----------------------------------------------------------- ####
####  Hashes() -- ハッシュを返す                                 ####
#### ----------------------------------------------------------- ####

sub Hashes($){
	my( $this ) = shift;
	$this->decode_any() unless $this->{decoded};
	$this->{queries};
}

#### ----------------------------------------------------------- ####
####  Keys() -- ハッシュのキー文字列の配列を返す                 ####
#### ----------------------------------------------------------- ####

sub Keys($){
	my( $this ) = shift;
	$this->decode_any() unless $this->{decoded};
	my( $ref ) = $this->{queries};
	my( $total ) = $#$ref;
	my( $i, @result );
	for( $i=0; $i<=$total; $i+=2 ){
		push( @result, $$ref[$i] );
	}
	@result;
}

#### ----------------------------------------------------------- ####
####  Values() -- ハッシュの値の配列を返す                       ####
#### ----------------------------------------------------------- ####

sub Values($){
	my( $this ) = shift;
	$this->decode_any() unless $this->{decoded};
	my( $ref ) = $this->{queries};
	my( $total ) = $#$ref;
	my( $i, @result );
	for( $i=1; $i<=$total; $i+=2 ){
		push( @result, $$ref[$i] );
	}
	@result;
}

#### ----------------------------------------------------------- ####
####  Upper() -- キー文字列のアルファベットを大文字に統一        ####
#### ----------------------------------------------------------- ####

sub Upper($){
	my( $this ) = shift;
	$this->{upper} = 1;
	return unless $this->{decoded};
	my( $ref ) = $this->{queries};
	my( $total ) = $#$ref;
	my( $i );
	for( $i=0; $i<=$total; $i+=2 ){
		$$ref[$i] =~ tr/a-z/A-Z/;
	}
}

#### ----------------------------------------------------------- ####
####  Lower() -- キー文字列のアルファベットを小文字に統一        ####
#### ----------------------------------------------------------- ####

sub Lower($){
	my( $this ) = shift;
	$this->{lower} = 1;
	return unless $this->{decoded};
	my( $ref ) = $this->{queries};
	my( $total ) = $#$ref;
	my( $i );
	for( $i=0; $i<=$total; $i+=2 ){
		$$ref[$i] =~ tr/A-Z/a-z/;
	}
}

#### ----------------------------------------------------------- ####
####  Nospace() -- キー文字列中の半角空白を削除する              ####
#### ----------------------------------------------------------- ####

sub Nospace($){
	my( $this ) = shift;
	$this->{lower} = 1;
	return unless $this->{decoded};
	my( $ref ) = $this->{queries};
	my( $total ) = $#$ref;
	my( $i );
	for( $i=0; $i<=$total; $i+=2 ){
		$$ref[$i] =~ s/\s+//g;
	}
}

#### ----------------------------------------------------------- ####
####  KanjiCode($$) -- ハッシュ中の日本語文字コードを統一        ####
#### ----------------------------------------------------------- ####

sub KanjiCode($;$){
	my( $this ) = shift;
	my( $coding ) = @_;
	$this->{kanji} = $coding || $this->{kanji};
	return unless $this->{decoded};
	my( $ref ) = $this->{queries};
	my( $total ) = $#$ref;
	my( $i );
	for( $i=1; $i<=$total; $i++ ){
		$_ = $$ref[$i];
		&jcode::convert( *_, $coding );
		$$ref[$i] = $_;
	}
}

#### ----------------------------------------------------------- ####
####  decode_any() -- GET なのか POST なのか……、分類して展開   ####
#### ----------------------------------------------------------- ####

sub decode_any($){
    my( $this ) = shift;
    return if $this->{decoded};
	$this->{decoded} = 1;
    if( $ENV{"REQUEST_METHOD"} eq "POST" ){
		&Memo::Print("Method: POST" );
        if( $ENV{"CONTENT_TYPE"} =~ /^multipart\/form-data/ ){
            $this->decode_multipart();
        }else{
		   	$this->decode_method_post();
        }
    }else{
		&Memo::Print("Method: GET" );
	   	$this->decode_method_get();
    }
	$this->Upper()     if $this->{upper};
	$this->Lower()     if $this->{lower};
	$this->KanjiCode() if $this->{kanji};
}

#### ----------------------------------------------------------- ####

sub decode_method_get($){
    my( $this ) = shift;
	my( $remain ) = $ENV{"QUERY_STRING"};
	# GET デコード結果を無名配列に格納する
	$this->{queries} = [ &DecodeString( $remain ) ];
}

#### ----------------------------------------------------------- ####

sub decode_method_post($){
    my( $this ) = shift;
	&Memo::Print( "Content-Type: application/x-www-form-urlencoded" );
	my( $remain );
   	read( STDIN, $remain, $ENV{"CONTENT_LENGTH"} );
	# POST デコード結果を無名配列に格納する
	$this->{queries} = [ &DecodeString( $remain ) ];
}

#### ----------------------------------------------------------- ####
####  decode_multipart() -- multipart/form-data を展開           ####
#### ----------------------------------------------------------- ####

sub decode_multipart($){
    my( $this ) = shift;
    my( @array, $boundary, $remain );
	&Memo::Print( "Content-Type: multipart/form-data" );
    $_ = $ENV{"CONTENT_TYPE"};
    if( /\s+boundary="([^"]+)"/i ){         #「"」で囲まれている Boundary
        $boundary = $1;
    }elsif( /\s+boundary=(\S+)/i ){         #「"」で囲まれていない Boundary
        $boundary = $1;
    }else{                                  # Boundary が見つからない場合
        return ();
    }
    $boundary = Escape_RegExp( $boundary ); # 正規表現のエスケープ (Misc.pm)
    &Memo::Print( "BOUNDARY = \"$boundary\"" );
    binmode( STDIN );                       # バイナリアップロードにも対応
    $Length = $ENV{"CONTENT_LENGTH"};
    $remain = &read_stdin();
    $remain =~ s/^--$boundary\r?\n//o;      # 先頭の Boundary は削除

    while( 1 ){
        local( $head );                             # ヘッダ（Content 情報）
		&Memo::Print( "Header? [$remain]" );
        if( $remain !~ /\r?\n\r?\n/ ){
            my( $string ) = &read_stdin();
            last if( $string eq "" );
            $remain .= $string;
            next;                                   # ヘッダ確認をやり直す
        }
        ( $head, $remain ) = ( $`, $' );			# ヘッダが読み終わった
        &jcode::convert( *head, "euc" );            # ヘッダ中の日本語対応
		&Memo::Print( "Header: [$head]" );
        my( $key );                                 # フィールドキー
        if( $head =~ /^Content-Disposition:.*\s+name="(.+?)"(;\s|$)/mi ){
            $key = $1;
        }else{
            $key = "NONAME";                        # キーが不明の場合
        }
		&Memo::Print( "Key:    [$key]" );
        my( $value ) = "";                  # 値を空に初期化
        my( $filename ) = "";               # ファイル名
        my( $textmode ) = "";               # デフォルトはバイナリモード
        if( $head =~ /^Content-Disposition:.*\s+filename="(.+?)"(;\s|$)/mi ){
            $value = $filename = $1;        # ファイル名を値とする
            $filename =~ tr/A-Z/a-z/;
            $filename =~ s/[^\w\-\.]+/-/g;  # テンポラリファイル名
            if( $head =~ /^Content-Type:\s*text\//mi ){
                $textmode = "(text)";       # テキストモード指定
            }
            &Memo::Print( "File-Upload: $filename $textmode" );
            open( OUT, "> $filename" ) || die $!;
            binmode(OUT) unless $textmode;  # DOS 対応バイナリ出力
        }
        my( $output );
        my( $save ) = $remain;
        $remain = &read_stdin();
        while( 1 ){
			&Memo::Print( "Check: [$save$remain]" );
            if( "$save$remain" =~ /\r?\n--$boundary(--)?\r?\n/o ){
				# Boundary が見つかったら、Boundary より前を出力
                ( $output, $save, $remain ) = ( $`, "", $' );
            }else{
				# Boundary が見つからなかったら、バッファ前半を出力
                ( $output, $save, $remain ) = ( $save, $remain, "" );
                $remain = &read_stdin();
            }
			&Memo::Print( "Out: [$output]" );
            $output =~ s/\n?\r\n?/\n/g if $textmode;
            if( $filename ){
                print OUT $output;          # テンポラリファイルに出力
            }else{
                $value .= $output;          # 値の変数に追加していく
            }
            last if( $Length == 0 );        # もう残りの文字列はない！
        }
        if( $filename ){
            close( OUT );                   # テンポラリファイルを閉じる
        }
		&Memo::Print( "\"$key\" = \"$value\"" );
        push( @array, $key, $value );       # とりあえず配列に格納
    }
    @array;                                 # その配列を返す
}

#### ----------------------------------------------------------- ####
####  read_stdin -- STDIN から $Each バイトを読み込む            ####
#### ----------------------------------------------------------- ####

sub read_stdin(){

    # $Length に予め読み込む総バイト数を代入しておく必要がある
    return unless $Length;                  # 既に全て読込済み

    # 残りの長さが $Each より少ない場合は、残りの分だけ読み込む
    my( $each ) = ( $Length < $Each ) ? $Length : $Each;
    read( STDIN, $string, $each );
    $Length -= $each;                       # 残りの長さ
	&Memo::Print( "Read: [$string]" );
    $string;                                # 読み込んだ文字列を返す
}

#### ----------------------------------------------------------- ####
####  Plain Old Documentation -- pod2html で HTML に変換してね   ####
#### ----------------------------------------------------------- ####
;$VERSION; # End of the script.
__END__

=head1 NAME

Query.pm -- Decode queries from web form

=head1 SYNOPSIS

    use Query;
    %hash = &Query::DecodeQuery();      # フォームからの入力をハッシュに格納
    
    use Query;
    $query = new Query;
    %hash = $query->Hashes();           # フォームからの入力をハッシュに格納
    @keys = $query->Keys();             # ハッシュのキーを配列に格納
    @values = $query->Values();         # ハッシュの値を配列に格納
    
    use Query;
    $query = new Query( "/tmp", 100 );  # ファイルアップロードを許可する
    %hash = $query->Hashes();           # フォームからの入力をハッシュに格納
    $filename = $query->FilePath( $hash{"upload"} ); # テンポラリファイル名
    $mimetype = $query->FileType( $hash{"upload"} ); # MIME タイプ

=head1 DESCRIPTION

Query モジュールは、WWW フォームから入力された文字列を処理し、
CGI プログラムの作成時の負担を和らげます。

=head2 Form Method

Query モジュールは、以下の入力方式（method）に対応しています：

    (1) <form>
    (2) <form method="get">
    (3) <form method="post">
    (4) <form method="post" enctype="application/x-www-form-urlencoded">
    (5) <form method="post" enctype="multipart/form-data">

なお、(1) は (2) の省略形、(3) は (4) の省略形と言えます。
Query モジュールは、環境変数を参照することで
これらの入力方式を自動的に判別します。
ただし SSI の場合は、SSI の仕様により
(1) (2) の形式しか使用できません。

=head2 File Upload

Query モジュールは Netscape Navigator などのクライアントからの、
C<multipart/form-data> を用いたファイルのアップロードにも対応しています。

ファイルがアップロードされた場合、ハッシュの値には
そのアップロードされたファイル名が代入されています。
サーバ上のテンポラリファイル名でなく、クライアントホスト上の
ローカルファイル名がそのまま入っています。
（例えば、「C<C:\Windows\System.ini>」等）

ただしセキュリティのため、デフォルトではファイルアップロードは
禁止されています。C<Hashes()> メソッドなどで
フォームからの入力を受け取る前に、
予め C<AllowUpload()> でアップロード許可を宣言しなければ
ファイルのアップロードは行われないので、注意が必要です。

また、テンポラリファイルはそのプロセスが終了する前
（Query のオブジェクトが消えた時点）で削除されます。
アップロードしたファイルをその後も使用する場合は、
テンポラリファイルをコピーしておく必要があります。

=head2 Unicode

Query モジュールは JIS・EUC・シフト JIS の日本語入力に対応しています。
これらの日本語コードは、内部で全て EUC に統一されます（デフォルト）。

その他にも、IE 4.0 などの新しいクライアントが生成できるらしい、
C<%uXXXX> 形式の Unicode を用いた日本語入力にも対応しています。
ただし、C<%uXXXX> 形式でなく、C<%XX%XX> 形式で表された Unicode には
対応しませんし、また動作確認もあまりできていません。
何しろ、どうやったら C<%uXXXX> を生成させできるのか、
そのやり方が分からないので。(爆)

=head1 SUBROUTINES

以下のサブルーチンは C<&Query::サブルーチン名();> の形式で使用します。

=item DecodeQuery()

WWW フォームから入力された文字列を展開し、ハッシュとして返します。
ハッシュ中の日本語コードは EUC に統一されています。

    %hash = &Query::DecodeQuery();

なお、C<DecodeQuery()> を呼べるのは 1 度だけで、
2 度目以降は undef が返されます。

=item DecodeFields()

基本的に C<DecodeQuery()> と同機能ですが、さらに、
ハッシュの全てのキー文字列中の半角空白を削除し、
また半角アルファベットを大文字に統一します。
例えば、"abc" は "ABC" に、"X Y" は "XY" にそれぞれ変換されます。
日本語コードや、ハッシュの値については C<DecodeQuery()> と同じです。

=item DecodeString( $string )

WWW フォームからの入力でなく、引数 C<$string> の文字列を展開します。
$string は C<application/x-www-form-urlencoded> 形式の文字列です
（GET 時の環境変数 C<$QUERY_STRING> と同じ形式）。

    $string = "NAME=Kawasaki+Yuusuke&REGION=Chiba";
    %hash = &Query::DecodeString( $string );

この結果、ハッシュ C<%hash> の内容は以下のようになります：

    $hash{"NAME"} = "Kawasaki Yuusuke";
    $hash{"REGION"} = "Chiba";

=back

=head1 METHODS

以下のメソッドは、全て
C<$query = new Query;>
などと C<new()> メソッドを用いてオブジェクトを作成してから
C<$query->MethodName();>
などとして使用します。

=item AllowUpload( $tempdir, $maxsize )

C<multipart/form-data> を用いたファイルのアップロードを許可します。

引数 C<$tempdir> に Query モジュールがテンポラリファイルを置く
ディレクトリ名（パス）できます。
省略時はカレントディレクトリ C<./> にテンポラリファイルを置きます。
テンポラリファイルは Query モジュール終了時に削除されますし、
明示的に C<ClearTemp()> サブルーチンを呼び出して削除することもできます。

また、 引数 C<$maxsize> には許可する最大の転送容量を
KB 単位で指定できます。省略時は容量制限がかかりませんが、
セキュリティのために設定することを推奨します。

    $query->AllowUpload();              # カレントディレクトリ・容量制限なし
    $query->AllowUpload( "/tmp" );      # /tmp ディレクトリ・容量制限なし
    $query->AllowUpload( ".", 100 );    # カレントディレクトリ・容量制限 100KB

=item FilePath( $filename )

C<multipart/form-data> を用いてアップロードされたファイルは、
C<AllowUpload()> で指定されたディレクトリに一旦保存されます。
C<FilePath()> はそのテンポラリファイルへのパスを返します。

引数 C<$filename> にアップロード前のクライアント上での
ローカルファイル名を指定します。
指定されたファイルがディレクトリに見つからない場合、
C<FilePath()> は undef を返します。

    $query = new Query;
    $query->AllowUpload( "/tmp" ); 		# /tmp ディレクトリを指定
    %hash = $query->Hashes();
    $filename = $query->FilePath( $hash{"upload"} ); # テンポラリファイル名
    open( IN, $filename ) || die $!;

=item FileType( $filename )

    $query = new Query;
    $query->AllowUpload( ".", 100 ); 	# 最大容量 100KB を指定
    %hash = $query->Hashes();
    $mimetype = $query->FileType( $hash{"upload"} ); # MIME タイプ
    open( IN, $filename ) || die $!;

=back

=head1 EXAMPLE

フォームからの全ての入力（キーと値の組合わせ）を表示する CGI プログラム：

    #!/usr/local/bin/perl
    use Query;                                          # Query.pm の読み込み
    print "Content-Type: text/plain\n\n";               # HTTP ヘッダの出力
    %input = &Query::Decode();                          # 展開
    print "# Key => Value\n\n";
    $no = 0;
    foreach $key ( sort keys %input ){                  # 全キーについて
        printf( "'%s' => '%s'\n", $key, $input{$key} ); # キーと値を表示
        $no ++;
    }
    print "\n# $no keys received.\n";                   # キーの総数の表示

アップロードされたテキストファイルをそのまま表示する CGI プログラム：

    #!/usr/local/bin/perl
    use Query;                                          # Query.pm の読み込み
    print "Content-Type: text/plain\n\n";               # HTTP ヘッダの出力
    $query = new Query( "/tmp", 100 );                  # アップロード許可
    %hash = $query->Hashes();                           # 展開
    $tempfile = $query->TempFile( $hash{"upload"} );    # テンポラリファイル
    open( IN, $tempfile ) || die $!;
    print <IN>;                                         # 全内容を一気に出力
    close( IN );

=head1 HISTORY

=item Version 0.11 (1998/1/24)
=item Version 0.12 (1998/1/25)
ファイルのアップロードに対応
=item Version 0.13 (1998/1/26)
クラス化
=back

=head1 TODO

    ・%uXXXX 形式の Unicode 入力の動作確認

=head1 AUTHOR

Kawasaki Yuusuke E<lt>F<u-suke@kawa.net>E<gt>

=cut