# -------------------------------------------------------------------- #
#   Encode561.pm - Encode::from_to compatible for Perl 5.6.x and 5.005
#   Copyright (C) 1998-2005 Kawasaki Yuusuke <u-suke@kawa.net>
# -------------------------------------------------------------------- #
#   2004/10/21  最初のバージョン
#   2004/10/25  EUC_JP → Latin1 の変換バグ修正
#   2004/10/28  EUC_JP → ISO-2022-JP の変換バグ修正
#   2004/11/07  POD を少し整備しました
#	2005/01/29  wide character 判別処理を修正(Perl 5.8.x 環境用)
# -------------------------------------------------------------------- #
    package Encode561;
    use strict;
    use vars qw( $VERSION $DEBUG );
    $VERSION = "0.05";
# -------------------------------------------------------------------- #
=head1 NAME

Encode561.pm - Encode::from_to compatible for Perl 5.6.x and 5.005

=head1 SYNOPSIS

    use Encode561;
    my $text = "Hello, World!\n";
    Encode561::from_to( $text, "utf8", "cp932" );
    print $text;

=head1 DESCRIPTION

Encode.pm は日本語だけでなく多言語の変換に有用ですが、
Perl 5.8.x 以降でしか利用できません。
しかし、サーバ運用上、どうしても Perl 5.005 や Perl 5.6.x といった
古いバージョンのまま稼動してるマシンも多いと思います。

Jcode.pm や Unicode::Map でも組み合わせることで
Encode.pm と同等の処理も実現できまうが、
インターフェースが異なるため、プログラムが複雑になってしまいます。

Encode561.pm は、Encode::from_to 関数と同等の処理を行う関数
Encode561::from_to 関数を提供します。

Perl 5.005 および 5.6.x のサーバ上で Encode561.pm を利用して
開発したプログラムを、Perl 5.8.x のサーバで本来の Encode.pm を
利用して稼動させることが可能になります。

また、Perl 5.8.x 上でも Encode561.pm を利用することも可能です。
しかし、Encode.pm 本体を利用したほうが処理も速いでしょうから、
プログラム中の『Encode561』を『Encode』と書き換えたほうがいいかと
思われます。

=head1 USAGE

from_to 関数の引数の書式は、Encode.pm のそれと同じです。

    [$length =] Encode561::from_to($octets, FROM_ENC, TO_ENC [, CHECK])

$octets には、変換したい文字列を指定します。
FROM_ENC には、変換前の現在の文字コードを指定します。
TO_ENC には、変換先の文字コードを指定します。
第４引数(CHECK)は、指定されていても無視されます。
$length は、変換後のバイト数が返ります。

=head1 CHARSETS

Encode561.pm では下記の文字コードを利用できます。

・内蔵ルーチンにより対応するコード：

    UTF-8
    Latin1 (ISO-8859-1,ASCII)

・Jcode.pm により対応するコード：

    Shift_JIS   (CP932)
    EUC_JP      (x-euc-jp)
    JIS         (ISO-2022-JP)

・Unicode::Map により対応する主なコード：

    EUC-KR (CP949)
    GB2312 (CP936)
    BIG5   (CP950)

※その他、Unicode::Map がサポートするコードは基本的に利用できます。
　Shift_JIS と CP932 の文字セット定義は本来異なりますが、簡便のため、
　同一視しています。（Jcode.pm における sjis として処理します）

・対応しないコード：

    UCS2
    UTF-16

※Encode561.pm では、16bitコードには対応しません。
　8bitコードまたは8bit×可変長コードのみ対応しています。

=head1 PATCHS

Jcode.pm および Unicode::Map では、Unicode から他のコードに変換時に
出力先文字セットで表現できない文字は「??」や「〓」に変換されたり、
削除されてしまいます。
Encode.pm ではそれを回避する Encode::FB_XMLCREF オプションがあります。
Jcode.pm および Unicode::Map で FB_XMLCREF 相当の機能を実現する
パッチプログラム（↓下記）を予め適用しておくことをお勧めします。
http://www.kawa.net/works/jcode/uni-escape.html
該当文字を &#xHHHH; の形式にエスケープすることで、文字化けを防ぎます。

=head1 TODO

Encode561.pm を用いることで Encode.pm がない環境（＝5.6.1以下）でも
Encode.pm に近い処理を実現できますが、しかし反面、
Jcode.pm または Unicode::Map は必須となってしまいます。
レンタルサーバ等でモジュールを追加インストールできず、
jcode.pl しか利用できない環境においても
Shift_JIS〜EUC-JP〜ISO-2022-JP 間の変換に限れば
利用できるように拡張するのも、需要があるかもしれませんね。

=head1 COPYRIGHT

    Copyright 2004 Kawasaki Yusuke <u-suke@kawa.net>
    http://www.kawa.net/

=cut
# -------------------------------------------------------------------- #
#   Encode.pm と Jcode.pm のコード名変換マップ
# -------------------------------------------------------------------- #
    my $ENC2JC = {
        "euc-jp"        =>  "euc",
        "euc_jp"        =>  "euc",
        "x-euc-jp"      =>  "euc",
        "x-sjis"        =>  "sjis",
        "shift_jis"     =>  "sjis",
        "shift-jis"     =>  "sjis",
        "cp932"         =>  "sjis",
        "iso-2022-jp"   =>  "jis",
        "utf8"          =>  "utf8",
        "utf-8"         =>  "utf8",
        "ascii"         =>  "ascii",
        "latin1"        =>  "ascii",
        "latin-1"       =>  "ascii",
        "iso-8859-1"    =>  "ascii",
    };
# -------------------------------------------------------------------- #
#   オブジェクトのキャッシュ
# -------------------------------------------------------------------- #
    my $CACHE_JCODE;
    my $CACHE_UNIMAP = {};
    my $CACHE_UNISTR;
# -------------------------------------------------------------------- #
#   定数（Encode.pm互換用）→ Encode561.pm では利用していません
# -------------------------------------------------------------------- #
sub FB_DEFAULT  {    0; }
sub FB_CROAK    {    1; }
sub FB_QUIET    {    4; }
sub FB_WARN     {    6; }
sub FB_PERLQQ   {  256; }
sub FB_HTMLCREF {  512; }
sub FB_XMLCREF  { 1024; }
# -------------------------------------------------------------------- #
#   変換前と変換後の文字コードを指定する
# -------------------------------------------------------------------- #
sub from_to {
    my $src = \$_[0];
    my $from = $_[1];
    my $to   = $_[2];
    my $opt  = $_[3];
    my $ref = ref $$src ? $$src : $src;     # 必ず１レベルのリファレンス
    $DEBUG and print STDERR "[from_to: $from to $to]\n";
    $DEBUG and print STDERR "[before: ",length($$ref)," bytes]\n";

    if ( $from eq $to ) {
        # 変換前後が同じコードの場合は何もしない
    } elsif ( $$ref !~ /[^\x00-\x7F]/ ) {
        # 文字列が 0〜127 までの範囲なら何もしない
        # Perl 5.8.x では、[^\x00-\x7F] と [\x80-\xFF] の意味が異なる
        # Perl 5.8.x では、後者は Latin-1 範囲のみに限定される
    } elsif ( $ENC2JC->{lc($from)} && $ENC2JC->{lc($to)} ) {
        # Jcode.pm が利用可能な範囲の場合は、EUC 経由で変換する
        &euc_encode( $from, $ref, $opt );           # 任意→EUC
        &euc_decode( $to,   $ref, $opt );           # EUC→任意
    } else {
        # UCS2 経由の方が早そうだが、簡単のため UTF8 経由で変換する
        &encode( $from, $ref, $opt );               # 任意→UTF8
        &decode( $to,   $ref, $opt );               # UTF8→任意
    }

    $DEBUG and print STDERR "[after: ",length($$ref)," bytes]\n";
    return length( $$ref );
}
# -------------------------------------------------------------------- #
#   他のコードから UTF8 に変換する
# -------------------------------------------------------------------- #
sub encode {
    my $from = $_[0];
    my $src = \$_[1];
    my $opt = $_[2];
    my $ref = ref $$src ? $$src : $src;     # 必ず１レベルのリファレンス
    my $jfrom = $ENC2JC->{lc($from)};
    $DEBUG and print STDERR "[encode: $from to utf8] $ref\n";

    if ( $from eq "utf8" ) {
        # 何もしない
    } elsif ( $jfrom eq "ascii" ) {
        &latin1_to_utf8( $ref );                    # Latin1→UTF8
    } elsif ( $jfrom ne "" ) {
        &euc_encode( $from, $ref, $opt );           # 任意→EUC
        &euc_decode( "utf8", $ref, $opt );          # EUC→UTF8
    } else {
        my $unimap = &require_unicode_map( $from );
        my $unistr = &require_unicode_string( $from );
        $$ref = $unimap->to_unicode( $$ref );       # 任意→UCS2
        $unistr->ucs2( $$ref );                     
        $$ref = $unistr->utf8();                    # UCS2→UTF8
    }
}
# -------------------------------------------------------------------- #
#   UTF8 から他のコードに変換する
# -------------------------------------------------------------------- #
sub decode {
    my $to = $_[0];
    my $src = \$_[1];
    my $opt = $_[2];
    my $ref = ref $$src ? $$src : $src;     # 必ず１レベルのリファレンス
    my $jto = $ENC2JC->{lc($to)};
    $DEBUG and print STDERR "[decode: utf8 to $to] $ref\n";

    if ( $to eq "utf8" ) {
        # 何もしない
    } elsif ( $jto eq "ascii" ) {
        &utf8_to_latin1( $ref );                    # UTF8→Latin1
    } elsif ( $jto ne "" ) {
        &euc_encode( "utf8", $ref, $opt );          # UTF8→EUC
        &euc_decode( $to, $ref, $opt );             # EUC→任意
    } else {
        my $unimap = &require_unicode_map( $to );
        my $unistr = &require_unicode_string( $to );
        $unistr->utf8( $$ref );
        $$ref = $unistr->ucs2();                    # UTF8→UCS2
        $$ref = $unimap->from_unicode( $$ref );     # UCS2→任意
    }
}
# -------------------------------------------------------------------- #
#   Jcode.pm を利用して、他のコードから EUC に変換する
# -------------------------------------------------------------------- #
sub euc_encode {
    my( $from, $ref, $opt ) = @_;
    my $jfrom = $ENC2JC->{lc($from)} or die "Unknown encoding '$from'\n";
    $DEBUG and print STDERR "[euc_encode: $jfrom to euc] $ref\n";

    if( $jfrom eq "ascii" ) {
        &latin1_to_ascii( $ref );                    # Latin1→ASCII(0〜128)
    } elsif( $jfrom ne "euc" ) {
        my $jcode = &require_jcode( $from );
        $$ref = $jcode->set( $ref, $jfrom )->euc();  # 任意→EUC
    }
}
# -------------------------------------------------------------------- #
#   Jcode.pm を利用して、EUC から他のコードに変換する
# -------------------------------------------------------------------- #
sub euc_decode {
    my( $to, $ref, $opt ) = @_;
    my $jto = $ENC2JC->{lc($to)} or die "Unknown encoding '$to'\n";
    my $jcode = &require_jcode( $to );
    $DEBUG and print STDERR "[euc_decode: euc to $jto] $ref\n";

    if ( $jto eq "ascii" ) {
        $$ref = $jcode->set( $ref, "euc" )->utf8(); # EUC→UTF8
        &utf8_to_latin1( $ref );                    # UTF8→Latin1
    } elsif ( $jto eq "sjis" ) {
        $$ref = $jcode->set( $ref, "euc" )->sjis(); # EUC→SJIS
    } elsif ( $jto eq "jis" ) {
        $$ref = $jcode->set( $ref, "euc" )->jis();  # EUC→JIS
    } elsif ( $jto eq "utf8" ) {
        $$ref = $jcode->set( $ref, "euc" )->utf8(); # EUC→UTF8
    }
}
# -------------------------------------------------------------------- #
#   Latin1(0〜255)→ASCII(0〜128) は自前で変換する
# -------------------------------------------------------------------- #
sub latin1_to_ascii {
    my $ref = shift;
    $$ref =~ s{
        ([\x80-\xFF])
    }{
        sprintf( "&#x%04X;", ord($1) );
    }gex;
}
# -------------------------------------------------------------------- #
#   Latin1(0〜255)→UTF8 は自前で変換する
# -------------------------------------------------------------------- #
sub latin1_to_utf8 {
    my $ref = shift;
    $$ref =~ s{
        ([\x80-\xFF])
    }{
        pack("CC"=>0xC0|(ord($1)>>6),0x80|(ord($1)&0x3F))
    }gex;
}
# -------------------------------------------------------------------- #
#   UTF8 の 0x0100〜0xFFFF を &#xHHHH; 表記にエスケープする
# -------------------------------------------------------------------- #
sub utf8_to_latin1 {
    my $ref = shift;
    $$ref =~ s{
        ([\xC0-\xC3])([\x80-\xBF])|
        ([\xC4-\xFF][\x80-\xBF]+)
    }{
        if ( $3 ) { 
            &one_utf8_escape($3);
        } else {
            pack( "C" => ((ord($1)&0x03)<<6)|(ord($2)&0x3F));
        }
    }gex;       # C000-
}
# -------------------------------------------------------------------- #
#   UTF8 文字列を &#xHHHH; 形式にエスケープする（１文字だけ）
# -------------------------------------------------------------------- #
sub one_utf8_escape {
    my $src = shift;
    my $array = [ unpack("C*"=>$src ) ];
    my $len = scalar @$array;
    my $ucs2 = shift @$array;
    if ( $len == 1 ) {
        $ucs2 &= 0x7F;          # 0000〜007F: 0xxxxxxx 
    } elsif ( $len == 2 ) {
        $ucs2 &= 0x1F;          # 0080〜07FF: 110xxxxx 10xxxxxx 
    } elsif ( $len == 3 ) {
        $ucs2 &= 0x0F;          # 0800〜FFFF: 1110xxxx 10xxxxxx 10xxxxxx 
    } else {
        return $src;
    }
    foreach my $chr ( @$array ) {
        $ucs2 = ( $ucs2 << 6 ) | ( $chr & 0x3F );
    }
    sprintf( "&#x%04X;", $ucs2 );
}
# -------------------------------------------------------------------- #
#   Jcode.pm を自動的に呼び出す
# -------------------------------------------------------------------- #
sub require_jcode {
    my $code = shift;
    if ( ! defined $CACHE_JCODE ) {
        if ( ! defined $Jcode::VERSION ) {
            eval "require 'Jcode.pm';";
        }
        if ( ! defined $Jcode::VERSION ) {
            die "Jcode.pm is required for $code\n";
        }
        $CACHE_JCODE = new Jcode();
    }
    $CACHE_JCODE;
}
# -------------------------------------------------------------------- #
#   Unicode::Map を自動的に呼び出す
# -------------------------------------------------------------------- #
sub require_unicode_map {
    my $code = shift;
    if ( ! defined $CACHE_UNIMAP->{$code} ) {
        if ( ! defined $Unicode::Map::VERSION ) {
            eval "require 'Unicode/Map.pm';";
        }
        if ( ! defined $Unicode::Map::VERSION ) {
            die "Unicode::Map is required for $code\n";
        }
        $CACHE_UNIMAP->{$code} = new Unicode::Map($code) 
            or die "Unknown encoding '$code'\n";
    }
    $CACHE_UNIMAP->{$code};
}
# -------------------------------------------------------------------- #
#   Unicode::String を自動的に呼び出す
# -------------------------------------------------------------------- #
sub require_unicode_string {
    my $code = shift;
    if ( ! defined $CACHE_UNISTR ) {
        if ( ! defined $Unicode::String::VERSION ) {
            eval "require 'Unicode/String.pm';";
        }
        if ( ! defined $Unicode::String::VERSION ) {
            die "Unicode::String is required for $code\n";
        }
        $CACHE_UNISTR = new Unicode::String();
    }
    $CACHE_UNISTR;
}
# -------------------------------------------------------------------- #
#   全角〜半角カタカナ変換クラス（内部EUCコードのみ）
# -------------------------------------------------------------------- #
package Encode561::JP::H2Z;
sub z2h {
    my $ref = shift;
    my $jcode = &Encode561::require_jcode( "z2h" );
    $jcode->set( $ref, "euc" )->z2h();
}
sub h2z {
    my $ref = shift;
    my $jcode = &Encode561::require_jcode( "h2z" );
    $jcode->set( $ref, "euc" )->h2z();
}
# -------------------------------------------------------------------- #
;1; # End of the script.
# -------------------------------------------------------------------- #