# -------------------------------------------------------------------- #
#   CGIparamJP.pm - CGI.pm wrapper for using Japanese characters
#   Copyright (C) 1998-2005 Kawasaki Yuusuke <u-suke@kawa.net>
# -------------------------------------------------------------------- #
#   1999/06/29 v1.77 CHECKBOX に対応した（Thanks to Yamato!）
#   1999/07/06 v1.79 KMimeMP.pm にファイルアップロード部分を分離した
#   1999/07/26 v1.81 KMimeMP.pm を use しなくても良くした
#   2000/05/12 v1.91 バグ修正: &decode_url_array()
#   2000/12/18 v2.00 絵文字自動判別、jcode.pl Jcode.pm 対応
#   2003/02/19 v2.01 絵文字エスケープ対応、&get_query_through() 追加
#   2003/06/05 v2.02 機種依存文字を〓に変換する(EUC)
#   2003/06/05 v2.03 PC 機種依存文字 Mozilla 対応
#   2003/06/30 v2.04 emoji=amp 対応。ドコモ標準絵文字を&#65432;に変換する
#   2004/03/10       ドコモ拡張絵文字は &#xHHHH; に変換する
#   2004/10/02       Vodafone 絵文字を &#xF000;〜 に移動、EZweb 絵文字修正
#   2004/10/20 v2.10 Windows 拡張 Shift_JIS (IBM拡張漢字)対応
#   2004/10/20 v2.11 emoji=escape オプションを削除
#   2004/10/20 v2.12 Encode.pm 対応、『8÷4=2±0』自動判別対応
#   2004/10/20 v2.13 内部 UTF-8 時はブラウザ側のエスケープをデコード
#   2004/10/20 v2.14 Unicode::Map 対応。中国語・韓国語入力に対応
#   2004/10/21 v2.15 Encode561 対応
#   2004/10/21 v2.16 EscapeSJIS 対応
#   2004/10/24 v2.17 EntityRef 対応
#   2004/10/26 v2.18 EscapeUTF8 対応
# -------------------------------------------------------------------- #
#   2004/11/08 v3.00 CGIparamJP.pm に変更。バージョン3開始
#   2005/02/23 v3.01 ファイルアップロードに対応
# -------------------------------------------------------------------- #
    use strict;
    package CGIparamJP;
    use vars qw( $VERSION $DEBUG @ISA );
    @ISA = qw( CGI );
    $VERSION = "3.01";
#   $DEBUG = \*STDOUT;
#   $DEBUG = \*STDERR;
# -------------------------------------------------------------------- #
=head1 NAME

CGIparamJP.pm - CGI.pm wrapper for using Japanese characters

=head1 SYNOPSIS

    use strict;
    use CGI;                        # 必ず use CGI してから
    use CGIparamJP;                 # 次に use CGIparamJP する順序

    my $workcode = "UTF8";          # 内部処理コード
    my $defcode = "Shift_JIS";      # 入力コードのデフォルト(自動判別失敗時)

    my $cgi = new CGIparamJP();
    my $entcode = $cgi->set_param_charset( $workcode, $defcode );
    my $query = $cgi->Vars();       # 全クエリを読み込む

    print "Content-Type: text/html\n\n";
    foreach my $key ( sort keys %$query ) {
        my $val = $query->{$key};
        print "$key : $val\n";
    }

=head1 DESCRIPTION

CGIparamJP.pm は CGI.pm を継承して、set_param_charset メソッドを追加します。
set_param_charset メソッド以外は通常通り CGI.pm を利用できます。

=head2 use CGIparamJP

「use CGI」は必ず「use CGIparamJP」の前に置いてください。

CGI.pm がない環境の場合は、CGIparamJP.pm の独自ルーチンにより
param、Vars メソッドを提供するため、「use CGI」は不要です。
ただし、この場合は CGI.pm が提供するファイルアップロード等の
仕組みは利用できません。

=head2 set_param_charset()

set_param_charset メソッドでは下記の文字コード自動判定ルールに基づいて、
クエリ変数中の文字コードを自動判別し、全てのクエリ変数を指定文字コードに
変換します。param メソッドや Vars メソッドを呼び出す前に
set_param_charset メソッドを呼び出してください。

デフォルト指定した入力文字コードの他に、
フォーム中に文字コード判別用のダミーの変数を埋め込むことで
ほぼ確実な文字コード判定を行います。

    <INPUT TYPE="hidden" NAME="8÷4" VALUE="2±0">

各文字コードごとに、『÷』と『±』の文字番号が異なることを利用しています。
判別が可能な文字コードは以下の通りです。

    日本語 JIS
    日本語 Shift_JIS    (CP932)
    日本語 EUC-JP
    韓国語 EUC-KR       (CP949)
    簡体字中国語 GB2312 (CP936)
    繁体字中国語 BIG5   (CP950)
    UTF8
    Latin1

または、クエリ変数 ie を利用して、文字コードを指定することも可能です。

    <INPUT TYPE="hidden" NAME="ie" VALUE="Shift_JIS">

ブラウザに自動変換されない環境でのみご利用ください。

=head1 TODO

ファイルアップロードに対応しているか動作確認する

=head1 AUTHORS

Copyright 1998-2004 Kawasaki Yusuke u-suke@kawa.net

=cut
# -------------------------------------------------------------------- #
    use Encode561;      # 文字コード変換
    use EscapeSJIS;     # Shift_JIS 絵文字・IBM 拡張漢字の変換
    use EscapeUTF8;     # オプション（内部コードUTF8の場合）
# -------------------------------------------------------------------- #
#  『use CGIparamJP;』を呼び出す前に『use CGI;』をしていなければ、
#   自前の関数で上書きする。（呼び出し順序に注意！）
# -------------------------------------------------------------------- #
sub import {
    if ( defined $CGI::VERSION ) {
        *new = undef;
        *param = undef;
        *delete_all = undef;
        *Vars = undef;
        *cookie = undef;
    } else {
        *new = \&CGIparamJP::orig::new;
        *param = \&CGIparamJP::orig::param;
        *delete_all = \&CGIparamJP::orig::delete_all;
        *Vars = \&CGIparamJP::orig::Vars;
        *cookie = \&CGIparamJP::orig::cookie;
    }
}
# -------------------------------------------------------------------- #
sub set_param_charset {
    $DEBUG and print $DEBUG "[set_param_charset=",join(" ",@_),"]\n";
    my $cgi = shift;
    my $workcode = shift;   # 内部処理コード（必須）
    my $entdefault = shift; # 入力コード（自動判別失敗時のデフォルト値）

    # いったん全てのキー・値をハッシュに読み込む
    my $oldvar = {};
    foreach my $key ( $cgi->param() ) {
		my @val = $cgi->param( $key );
        $oldvar->{$key} = ( scalar @val > 1 ) ? \@val : $val[0];
    }

    # 文字コードを変換する
    my( $newvar, $entcode ) = &convert_hash( $oldvar, $workcode, $entdefault );

    # 全てのキーをいったん削除する
    $cgi->delete_all();

    # 全てのキーを再び登録し直す
    foreach my $key ( keys %$newvar ) {
        my $val = $newvar->{$key};
        if ( ! ref $val ) {
            $cgi->param( "-name" => $key, "-value" => $val );
        } elsif ( ref $val ne "ARRAY" ) {
            $cgi->param( "-name" => $key, "-value" => $val );
        } elsif ( scalar @$val == 1 ) {
            $cgi->param( "-name" => $key, "-value" => $val->[0] );
        } else {
            $cgi->param( "-name" => $key, "-values" => $val );
        }
    }

    # 入力文字コードを返す
    $entcode;
}
# -------------------------------------------------------------------- #
sub convert_hash {
    $DEBUG and print $DEBUG "[convert_hash:",join(" ",@_),"]\n";
    my $oldvar = shift;
    my $workcode = shift;   # 内部処理コード（必須）
    my $entdefault = shift; # 入力コード（自動判別失敗時のデフォルト値）

    my $entcode;			# 入力コード（確定）
    # 入力文字コードを自動判定する
	$entcode ||= &charset_detect( $oldvar );
	# クエリ変数 ie でも指定できる
	$entcode ||= $oldvar->{ie} if defined $oldvar->{ie};
	# エスケープシーケンスや128〜255があれば、デフォルトの文字コードにする
    $entcode ||= $entdefault if scalar grep {/[\e\x80-\xFF]/} %$oldvar;

    # 入力コード判定に失敗かつデフォルト値未指定だったら終了
    return (wantarray ? ( $oldvar, undef ) : $oldvar) unless $entcode;

    # 内部コード未指定だったら変換せずに終了
    return (wantarray ? ( $oldvar, $entcode ) : $oldvar) unless $workcode;

    # 入力コードが Shift_JIS なら、EscapeSJIS を利用する
    my $entsjis;
    if ( $entcode =~ /^(CP932|Shift[\_\-]?JIS)$/i && 
         defined $EscapeSJIS::VERSION ) {
        $entsjis ++;
    }

    # EntityRef.pm が利用可能なら、利用する
    my $entref;
    if ( defined $EntityRef::VERSION ) {
        $entref = new EntityRef();
    }

    # 内部コードが UTF-8 の場合は、&#xHHHH; 表記をデコードする
    my $escutf8;
    if ( $workcode =~ /^UTF-?8$/i && 
         defined $EscapeUTF8::VERSION ) {
        $escutf8 ++;
    }

    # 文字コードを変換する、絵文字エスケープや、実体参照の展開
    my $newvar = {};
    foreach my $key ( keys %$oldvar ) {
        my $val = $oldvar->{$key};
        foreach my $str ( $key, (ref $val eq "ARRAY" ? @$val : $val) ) {
#           $DEBUG and print $DEBUG "[convert_hash:$key=$str]\n";
			next if ref $str;
            EscapeSJIS::escape( \$str ) if $entsjis;
            Encode561::from_to( \$str, $entcode, $workcode );
            $entref->entity2hex( \$str ) if $entref;
            EscapeUTF8::unescape( \$str ) if $escutf8;
        }
        $newvar->{$key} = $val;
    }

	# ファイルアップロードでは、Fh クラスのリファレンスになるので、
	# 文字コード変換できない。でもスカラーでファイル名が読めそう。

    return (wantarray ? ( $newvar, $entcode ) : $newvar);
}
# -------------------------------------------------------------------- #
#   配列中の各値の文字コードを↓の判定用ダミー変数から自動判別する
#   <INPUT TYPE="hidden" NAME="8÷4" VALUE="2±0">
#   『÷』と『±』は、言語ごとに文字コードが異なることを利用している
# -------------------------------------------------------------------- #
#   現在は utf8／sjis／euc のみ対応だが、今後は Encode.pm に対応していきたい
#   ASCII   Unicode 日本語  日本語  GB2312  韓国語  BIG5
#   LATIN-1 UTF-8   CP932   EUC-JP  CP936   CP949   CP950  # NAME
#   00F7    C3B7    8180    A1E0    A1C2    A1C0    A1D2   # DIVISION SIGN   ÷
#   00B1    C2B1    817D    A1DE    A1C0    A1BE    A1D3   # PLUS-MINUS SIGN ±
# -------------------------------------------------------------------- #
sub charset_detect {
    $DEBUG and print $DEBUG "[charset_detect:",join(" ",@_),"]\n";
    my $hash = shift;
    my $getcode;

	# 各コードごとの DIVISION SIGN ÷ の生文字列（自動判別用）
	my $DIVISION_SIGN = {
		"\e\$B\x21\x60\e\(B" => "iso-2022-jp",	# 日本語 JIS
		"\x81\x80"	=>	"cp932",				# 日本語 Shift_JIS
		"\xA1\xE0"	=>	"euc-jp",				# 日本語 EUC-JP
		"\xA1\xC2"	=>	"cp936",				# 簡体字中国語 GB2312
		"\xA1\xC0"	=>	"cp949",				# 韓国語 EUC-KR
		"\xA1\xD2"	=>	"cp950",				# 繁体字中国語 BIG5
		"\xC3\xB7"	=>	"utf8", 				# UTF-8
		"\xF7"		=>	"iso-8859-1",			# Latin1
	};

	# 各コードごとの PLUS-MINUS SIGN ± の生文字列（自動判別用）
	my $PLUSMINUS_SIGN = {
		"\e\$B\x21\x5E\e\(B" => "iso-2022-jp",	# 日本語 JIS
		"\x81\x7D"	=>	"cp932",				# 日本語 Shift_JIS
		"\xA1\xDE"	=>	"euc-jp",				# 日本語 EUC-JP
		"\xA1\xC0"	=>	"cp936",				# 簡体字中国語 GB2312
		"\xA1\xBE"	=>	"cp949",				# 韓国語 EUC-KR
		"\xA1\xD3"	=>	"cp950",				# 繁体字中国語 BIG5
		"\xC2\xB1"	=>	"utf8", 				# UTF-8
		"\xB1"		=>	"iso-8859-1",			# Latin1
	};

    # 正規表現を | で並べる
    my $DIVISION_RE  = join( "|", map {"\Q$_\E"} sort keys %$DIVISION_SIGN );
    my $PLUSMINUS_RE = join( "|", map {"\Q$_\E"} sort keys %$PLUSMINUS_SIGN );

    foreach my $key ( keys %$hash ) {

        # クエリ変数名が「8÷4」の形式になっているか
        next unless ( $key =~ /^(\d+)($DIVISION_RE)(\d+)$/ );
        my( $div1, $strkey, $div2 ) = ( $1, $2, $3 );
        next unless $div1;              # 分子は必ず真
        next unless $div2;              # 分母も必ず真
        my $codekey = $DIVISION_SIGN->{$strkey} or next;
        $DEBUG and print $DEBUG "[key:$div1/$div2=$codekey]\n";

        # クエリ変数値が「2±0」の形式になっているか
		my $val = $hash->{$key};
		$val = $val->[0] if ref $val;
        next unless ( $val =~ /^(\d+)($PLUSMINUS_RE)(\d+)$/ );
        my( $pls1, $strval, $pls2 ) = ( $1, $2, $3 );
        next unless $pls1;              # 解は必ず真
        next if $pls2;                  # ±の右側は必ず0
        my $codeval = $PLUSMINUS_SIGN->{$strval} or next;
        $DEBUG and print $DEBUG "[value:$pls1+$pls2=$codeval]\n";

        # 検出した文字コードが等しくて、かつ計算式も正しければ確定
        if ( $codekey eq $codeval && $div1 / $div2 == $pls1 ) {
            $DEBUG and print $DEBUG "[detect:$codekey]\n";
            return $codekey;            # 確定した
        }
    }

    undef;                              # 検出できなかった
}
# ==================================================================== #
    package CGIparamJP::orig;
	use vars qw( $DEBUG );
# ==================================================================== #
sub new {
	$DEBUG = $CGIparamJP::DEBUG;
    $DEBUG and print $DEBUG "[new:",join(",",@_),"]\n";
    my $package = shift;
    my $obj = &input_query();
    bless $obj, $package;
    $obj;
}
# -------------------------------------------------------------------- #
sub delete_all {
    my $obj = shift;
    $DEBUG and print $DEBUG "[delete_all:",join(",",@_),"]\n";
    %$obj = ();
}
# -------------------------------------------------------------------- #
sub param {
    my $obj = shift;
    $DEBUG and print $DEBUG "[param:",join(",",@_),"]\n";

    if ( scalar @_ == 0 ) {         # 全パラメータ名のリスト
        return keys %$obj;
    } elsif ( scalar @_ == 1 ) {    # 指定パラメータの値
        my $key = shift;
        my $val = $obj->{$key};
        if ( ! ref $val ) {
            return $val;            # もともとスカラー値ならスカラー値を返す
        } elsif ( wantarray ) {
            return @$val;           # 配列値を返せるなら、配列値を返す
        } else {
            return join( "\0", @$val );     # \0 区切りで配列を並べる仕様？
        }
    } elsif ( scalar @_ == 2 ) {    # パラメータ値の変更
        my( $key, $val ) = @_;
        $obj->{$key} = $val;
    } elsif ( scalar @_ == 4 ) {    # パラメータ値の変更
        my $hash = { @_ };
        my $key = $hash->{"-name"};
        my $val = $hash->{"-values"} || $hash->{"-value"};
        $DEBUG and print $DEBUG "[param:$key=$val]\n";
        $obj->{$key} = $val;
    }
}
# -------------------------------------------------------------------- #
sub cookie {
    my $obj = shift;
    $DEBUG and print $DEBUG "[cookie:",join(",",@_),"]\n";

	undef;
}
# -------------------------------------------------------------------- #
sub Vars {
    my $obj = shift;
    $DEBUG and print $DEBUG "[Vars:",join(",",@_),"]\n";
    
    my $hash = {};
    foreach my $key ( $obj->param() ) {
        $hash->{$key} = $obj->param($key);
        $DEBUG and print $DEBUG "[Vars:$key=$hash->{$key}]\n";
    }

    $hash;
}
# -------------------------------------------------------------------- #
sub input_query {
    my $method   = $ENV{REQUEST_METHOD} if exists $ENV{REQUEST_METHOD};
    my $mimetype = $ENV{CONTENT_TYPE}   if exists $ENV{CONTENT_TYPE};
    my $length   = $ENV{CONTENT_LENGTH} if exists $ENV{CONTENT_LENGTH};

    my $enter;
    if( $method eq "POST" ){                    # クエリーの読み込み
        if( $mimetype =~ m#multipart/form-data#i ){
            die "CGIparamJP.pm - $mimetype is not supported.\n";
        }else{
            read( *STDIN, $enter, $length );    # 通常の POST の場合
        }
    } elsif ( exists $ENV{QUERY_STRING} ) {
        $enter = $ENV{QUERY_STRING};
    }

    my $query = {};
    foreach my $elem ( split( /[&;]/, $enter )){
        my( $key, $val ) = split( /=/, $elem, 2 );
        $key =~ s/%([0-9A-Fa-f]{2})/pack(C=>hex($1))/ge;
        $key =~ tr/+/ /;
        $val =~ s/%([0-9A-Fa-f]{2})/pack(C=>hex($1))/ge;
        $val =~ tr/+/ /;
        $query->{$key} = [] unless ref $query->{$key};
        push( @{$query->{$key}}, $val );
    }

    $query;
}
# -------------------------------------------------------------------- #
;1; # End of the script.
# -------------------------------------------------------------------- #