# -------------------------------------------------------------------- #
#   EscapeJIS.pm - Escape IBM extended Kanji and emoji in ISO-2022-JP
#   Copyright (C) 2000-2004 Kawasaki Yuusuke <u-suke@kawa.net>
# -------------------------------------------------------------------- #
#   2004/10/25  unescape に対応
#   2004/10/28  require_mime_base64 対応
# -------------------------------------------------------------------- #
    package EscapeJIS;
    use strict;
    use vars qw( $VERSION );
    $VERSION = "0.10";
# -------------------------------------------------------------------- #
=head1 NAME

EscapeJIS.pm - Escape Kanji and emoji in ISO-2022-JP

=head1 SYNOPSIS

    use EscapeJIS;
    my $text = "\e\$B#J#I#S\e\(B &#xE63E; \e\$B3(J8;z\e\(B\n";
    EscapeJIS::unescape( \$text );      
    EscapeJIS::mime_encode( \$text );   
    print $text;

=head1 DESCRIPTION

escape 関数では、今のところ何もしません。
将来的には、ISO-2022-JP 中の文字のエスケープに対応したいです。

unescape 関数では、JIS コードの文字列中に含まれる &#xHHHH; 形式の
携帯絵文字やIBM拡張漢字を適切なバイナリコードに変換することで、
メール中でも絵文字や拡張漢字を利用できるようにします。

    ドコモ絵文字    &#xHHHH; 形式からバイナリコードに変換します。
                    Outlook や Becky! では絵文字フォントがあれば
                    表示可能ですが、ドコモ携帯実機では表示できません。
                    携帯実機宛には Shift_JIS のメールを利用してください。
    Vodafone絵文字  &#xHHHH; 形式からバイナリコードに変換します。
                    Vodafone携帯実機で表示可能です。
    EZweb絵文字     &#xHHHH; 形式絵文字をバイナリコードに変換します。
                    EZweb携帯実機で表示可能です。
    IBM拡張漢字     &#xHHHH; 形式の該当漢字をバイナリコードに変換します。
                    対応しているのは、IBM拡張漢字と丸数字、「～」です。
                    それ以外の全ての漢字を変換するわけではありません。
                    それ以外の漢字は EscapeUTF8::unescape を利用してください。

mime_encode 関数では、メールヘッダの変換に対応します。
先に unescape した後に mime_encode を呼び出してください。
なお、Jcode.pm の mime_encode 関数では絵文字類のコードが
含まれる場合に文字化けする可能性があります。

=head1 SEE ALSO

http://www.nttdocomo.co.jp/p_s/imode/tag/emoji/list.html
http://www.dp.j-phone.com/dp/tool_dl/web/picword_01.php
http://www.au.kddi.com/ezfactory/tec/spec/3.html

=head1 AUTHORS

Copyright 2004 Kawasaki Yusuke u-suke@kawa.net

=cut
# -------------------------------------------------------------------- #
#   デバッグモード
# -------------------------------------------------------------------- #
    my $DEBUG;
# -------------------------------------------------------------------- #
#   $DEBUG ++;
# -------------------------------------------------------------------- #
#   定数
# -------------------------------------------------------------------- #
    my $JISBEG = "\e\$B";
    my $JISEND = "\e\(B";
# -------------------------------------------------------------------- #
#   IBM拡張漢字・要注意文字の Shift_JIS 一覧表
# -------------------------------------------------------------------- #
#    my $IBM_SJIS2SJIS = [
#        0x2141,             # “～”
#        0x8740 .. 0x8753,   # ①～⑳
#        0xFA40 .. 0xFA7E,   # IBM拡張漢字1
#        0xFA80 .. 0xFAFC,   # IBM拡張漢字2
#        0xFB40 .. 0xFB7E,   # IBM拡張漢字3
#        0xFB80 .. 0xFBFC,   # IBM拡張漢字4
#        0xFC40 .. 0xFC4B,   # IBM拡張漢字5
#    ];
# -------------------------------------------------------------------- #
#   IBM拡張漢字・要注意文字の Shift_JIS→JIS 変換マップ
# -------------------------------------------------------------------- #
    my $IBM_SJIS2JIS = [qw(

--FULLWIDTH_TILDE
2141

--MARUSUJI
2D21 2D22 2D23 2D24 2D25 2D26 2D27 2D28 2D29 2D2A 
2D2B 2D2C 2D2D 2D2E 2D2F 2D30 2D31 2D32 2D33 2D34

--FA40_to_FAFC
7C71 7C72 7C73 7C74 7C75 7C76 7C77 7C78 7C79 7C7A 2D35 2D36 2D37 2D38 2D39 2D3A
2D3B 2D3C 2D3D 2D3E 224C 7C7C 7C7D 7C7E 2D6A 2D62 2D64 2268 7921 7922 7923 7924
7925 7926 7927 7928 7929 792A 792B 792C 792D 792E 792F 7930 7931 7932 7933 7934
7935 7936 7937 7938 7939 793A 793B 793C 793D 793E 793F 7940 7941 7942 7943 ----
7944 7945 7946 7947 7948 7949 794A 794B 794C 794D 794E 794F 7950 7951 7952 7953
7954 7955 7956 7957 7958 7959 795A 795B 795C 795D 795E 795F 7960 7961 7962 7963
7964 7965 7966 7967 7968 7969 796A 796B 796C 796D 796E 796F 7970 7971 7972 7973
7974 7975 7976 7977 7978 7979 797A 797B 797C 797D 797E 7A21 7A22 7A23 7A24 7A25
7A26 7A27 7A28 7A29 7A2A 7A2B 7A2C 7A2D 7A2E 7A2F 7A30 7A31 7A32 7A33 7A34 7A35
7A36 7A37 7A38 7A39 7A3A 7A3B 7A3C 7A3D 7A3E 7A3F 7A40 7A41 7A42 7A43 7A44 7A45
7A46 7A47 7A48 7A49 7A4A 7A4B 7A4C 7A4D 7A4E 7A4F 7A50 7A51 7A52 7A53 7A54 7A55
7A56 7A57 7A58 7A59 7A5A 7A5B 7A5C 7A5D 7A5E 7A5F 7A60 7A61 7A62

--FB40_to_FBFC
7A63 7A64 7A65 7A66 7A67 7A68 7A69 7A6A 7A6B 7A6C 7A6D 7A6E 7A6F 7A70 7A71 7A72
7A73 7A74 7A75 7A76 7A77 7A78 7A79 7A7A 7A7B 7A7C 7A7D 7A7E 7B21 7B22 7B23 7B24
7B25 7B26 7B27 7B28 7B29 7B2A 7B2B 7B2C 7B2D 7B2E 7B2F 7B30 7B31 7B32 7B33 7B34
7B35 7B36 7B37 7B38 7B39 7B3A 7B3B 7B3C 7B3D 7B3E 7B3F 7B40 7B41 7B42 7B43 ----
7B44 7B45 7B46 7B47 7B48 7B49 7B4A 7B4B 7B4C 7B4D 7B4E 7B4F 7B50 7B51 7B52 7B53
7B54 7B55 7B56 7B57 7B58 7B59 7B5A 7B5B 7B5C 7B5D 7B5E 7B5F 7B60 7B61 7B62 7B63
7B64 7B65 7B66 7B67 7B68 7B69 7B6A 7B6B 7B6C 7B6D 7B6E 7B6F 7B70 7B71 7B72 7B73
7B74 7B75 7B76 7B77 7B78 7B79 7B7A 7B7B 7B7C 7B7D 7B7E 7C21 7C22 7C23 7C24 7C25
7C26 7C27 7C28 7C29 7C2A 7C2B 7C2C 7C2D 7C2E 7C2F 7C30 7C31 7C32 7C33 7C34 7C35
7C36 7C37 7C38 7C39 7C3A 7C3B 7C3C 7C3D 7C3E 7C3F 7C40 7C41 7C42 7C43 7C44 7C45
7C46 7C47 7C48 7C49 7C4A 7C4B 7C4C 7C4D 7C4E 7C4F 7C50 7C51 7C52 7C53 7C54 7C55
7C56 7C57 7C58 7C59 7C5A 7C5B 7C5C 7C5D 7C5E 7C5F 7C60 7C61 7C62

--FC40_to_FC4B
7C63 7C64 7C65 7C66 7C67 7C68 7C69 7C6A 7C6B 7C6C 7C6D 7C6E
)];
# -------------------------------------------------------------------- #
#   IBM拡張漢字・要注意文字の Shift_JIS→Unicode 変換マップ
# -------------------------------------------------------------------- #
    my $IBM_SJIS2UCS2 = [qw(
--FULLWIDTH_TILDE
FF5E

--MARUSUJI
2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 
246A 246B 246C 246D 246E 246F 2470 2471 2472 2473

--FA40_to_FAFC
2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2160 2161 2162 2163 2164 2165
2166 2167 2168 2169 FFE2 FFE4 FF07 FF02 3231 2116 2121 2235 7E8A 891C 9348 9288
84DC 4FC9 70BB 6631 68C8 92F9 66FB 5F45 4E28 4EE1 4EFC 4F00 4F03 4F39 4F56 4F92
4F8A 4F9A 4F94 4FCD 5040 5022 4FFF 501E 5046 5070 5042 5094 50F4 50D8 514A ----
5164 519D 51BE 51EC 5215 529C 52A6 52C0 52DB 5300 5307 5324 5372 5393 53B2 53DD
FA0E 549C 548A 54A9 54FF 5586 5759 5765 57AC 57C8 57C7 FA0F FA10 589E 58B2 590B
5953 595B 595D 5963 59A4 59BA 5B56 5BC0 752F 5BD8 5BEC 5C1E 5CA6 5CBA 5CF5 5D27
5D53 FA11 5D42 5D6D 5DB8 5DB9 5DD0 5F21 5F34 5F67 5FB7 5FDE 605D 6085 608A 60DE
60D5 6120 60F2 6111 6137 6130 6198 6213 62A6 63F5 6460 649D 64CE 654E 6600 6615
663B 6609 662E 661E 6624 6665 6657 6659 FA12 6673 6699 66A0 66B2 66BF 66FA 670E
F929 6766 67BB 6852 67C0 6801 6844 68CF FA13 6968 FA14 6998 69E2 6A30 6A6B 6A46
6A73 6A7E 6AE2 6AE4 6BD6 6C3F 6C5C 6C86 6C6F 6CDA 6D04 6D87 6D6F

--FB40_to_FBFC
6D96 6DAC 6DCF 6DF8 6DF2 6DFC 6E39 6E5C 6E27 6E3C 6EBF 6F88 6FB5 6FF5 7005 7007
7028 7085 70AB 710F 7104 715C 7146 7147 FA15 71C1 71FE 72B1 72BE 7324 FA16 7377
73BD 73C9 73D6 73E3 73D2 7407 73F5 7426 742A 7429 742E 7462 7489 749F 7501 756F
7682 769C 769E 769B 76A6 FA17 7746 52AF 7821 784E 7864 787A 7930 FA18 FA19 ----
FA1A 7994 FA1B 799B 7AD1 7AE7 FA1C 7AEB 7B9E FA1D 7D48 7D5C 7DB7 7DA0 7DD6 7E52
7F47 7FA1 FA1E 8301 8362 837F 83C7 83F6 8448 84B4 8553 8559 856B FA1F 85B0 FA20
FA21 8807 88F5 8A12 8A37 8A79 8AA7 8ABE 8ADF FA22 8AF6 8B53 8B7F 8CF0 8CF4 8D12
8D76 FA23 8ECF FA24 FA25 9067 90DE FA26 9115 9127 91DA 91D7 91DE 91ED 91EE 91E4
91E5 9206 9210 920A 923A 9240 923C 924E 9259 9251 9239 9267 92A7 9277 9278 92E7
92D7 92D9 92D0 FA27 92D5 92E0 92D3 9325 9321 92FB FA28 931E 92FF 931D 9302 9370
9357 93A4 93C6 93DE 93F8 9431 9445 9448 9592 F9DC FA29 969D 96AF 9733 973B 9743
974D 974F 9751 9755 9857 9865 FA2A FA2B 9927 FA2C 999E 9A4E 9AD9

--FC40_to_FC4B
9ADC 9B75 9B72 9B8F 9BB1 9BBB 9C00 9D70 9D6B FA2D 9E19 9ED1
)];
# -------------------------------------------------------------------- #
#   IBM拡張漢字の Unicode(16進数)→JIS(10進数) 変換マップを作成する
#   ハッシュのキーは UCS2 16進数、値は JIS バイナリとする
# -------------------------------------------------------------------- #
my $CACHE_IBM_UCS22JIS;
sub init_ibm_ucs2_to_jis {
    return $CACHE_IBM_UCS22JIS if ref $CACHE_IBM_UCS22JIS;
    my %hash;
    @hash{ grep {!/^-/} @$IBM_SJIS2UCS2 } = 
           map { pack(n=>hex($_)) } grep {!/^-/} @$IBM_SJIS2JIS;
    $CACHE_IBM_UCS22JIS = \%hash;
}
# -------------------------------------------------------------------- #
#   JIS コード中の携帯絵文字等を &#xHHHH; 表記に変換する
# -------------------------------------------------------------------- #
sub escape {
    my $src = \$_[0];
    my $ref = ref $$src ? $$src : $src;     # 必ず１レベルのリファレンス

    # 未実装

    undef;
}
# -------------------------------------------------------------------- #
#   JIS コード中の &#xHHHH; 表記の携帯絵文字等をバイナリ展開する
# -------------------------------------------------------------------- #
sub unescape {
    my $src = \$_[0];
    my $ref = ref $$src ? $$src : $src;     # 必ず１レベルのリファレンス

    my $ucs22jis = &init_ibm_ucs2_to_jis();

    $$ref =~ s{
        (\&\#x([0-9A-Fa-f]{4});)
    }{
        my $org = $1;
        my $new = undef;
        my $hex = $2;
        my $ucs2 = hex($hex);
        if ( $ucs2 >= 0xE63E && $ucs2 <= 0xE757 ) {
            $new = &one_unescape_docomo($ucs2);
        } elsif (( $ucs2 >= 0xE468 && $ucs2 <= 0xE5DF )||
            ( $ucs2 >= 0xEA80 && $ucs2 <= 0xEB88 )) {
            $new = &one_unescape_ezweb($ucs2);
        } elsif ( $ucs2 >= 0xF001 && $ucs2 <= 0xF539 ) {
            $new = &one_unescape_vodafone($ucs2);
#       } elsif ( $ucs2 >= 0xE001 && $ucs2 <= 0xE539 ) {
#           $new = &one_unescape_vodafone($ucs2);
        } elsif ( exists $ucs22jis->{$hex} ) {
            $new = $JISBEG.$ucs22jis->{$hex}.$JISEND;
        }
        defined $new ? $new : $org;
    }sgex;

    $$ref =~ s/\Q$JISEND\E\Q$JISBEG\E//g;
}
# -------------------------------------------------------------------- #
#   メールの MIME ヘッダデコード
# -------------------------------------------------------------------- #
sub mime_decode {
    my $src = \$_[0];
    my $ref = ref $$src ? $$src : $src;     # 必ず１レベルのリファレンス
    &require_mime_base64();                 # MIME::Base64 を読み込む
    $$ref =~ s{
        \=\?ISO-2022-JP\?B\?([^\s\?]+)\?\=
    }{
        MIME::Base64::decode_base64($1);
    }iegx;
}
# -------------------------------------------------------------------- #
#   メールの MIME ヘッダエンコード
# -------------------------------------------------------------------- #
sub mime_encode {
    my $src = \$_[0];
    my $ref = ref $$src ? $$src : $src;     # 必ず１レベルのリファレンス
    &require_mime_base64();                 # MIME::Base64 を読み込む
    $$ref =~ s{
        ( \e\$B ((?:[\x21-\x7E][\x21-\x7E])+) \e\(B )
    }{
        "=?ISO-2022-JP?B?".MIME::Base64::encode_base64($1, "")."?=";
    }egx;
}
# -------------------------------------------------------------------- #
#   ドコモ絵文字 &#xE63E;～&#xE757;
#   Outlook や Becky! では、Shift_JIS コードのうち
#   0x80～0xFF を SO(0x0E)～SI(0x0F) で囲むことで、
#   ISO-2022-JP 中でも Shift_JIS コードを利用できるらしい。
#       40～7E  何もしない
#       80～9E  SO/SIで囲む
#       9F～FC  上位ビットを落として1F～7Cに変換し、SO/SIで囲む
#   なお、Shift_JIS コードの２バイト目が 0x40～0x7E の場合は
#   １バイトのみ SO/SI で囲んで、２バイト目はそのままとする。
# -------------------------------------------------------------------- #
sub one_unescape_docomo {
    my $ucs2 = shift or return;
    my $sjis;
    if ( $ucs2 >= 0xE63E && $ucs2 <= 0xE757 ) {
        if ( $ucs2 <= 0xE69B ) {
            $sjis = $ucs2+4705;
        } elsif ( $ucs2 <= 0xE6DA ) {
            $sjis = $ucs2+4772;
        } else {
            $sjis = $ucs2+4773;
        }
    }
    my $str;
    if ( $sjis ) {
        $str = pack(n=>$sjis);
        $str =~ s/([\x80-\x9E])/pack("C*"=>0x0E,ord($1)     ,0x0F)/egx;
        $str =~ s/([\x9F-\xFC])/pack("C*"=>0x0E,ord($1)&0x7F,0x0F)/egx;
        $str =~ s/\x0F\x0E//g;
    }
    $str;
}
# -------------------------------------------------------------------- #
#   Vodafone 絵文字 &#xE001;～&#xE539;、&#xF001;～&#xF539;
# -------------------------------------------------------------------- #
sub one_unescape_vodafone {
    my $code = shift or return;
    my $str;
    my $high1 = ( $code & 0xF000 );
    my $high2 = ( $code & 0x0F00 ) >> 8;
    my $low = $code & 0xFF;
    my $ver = ( $ENV{HTTP_USER_AGENT} =~ m#^J-PHONE/(\d+)\.# )[0];
    if (( $high1 == 0xE000 || $high1 == 0xF000 ) &&
         (( $high2 <= 2 && $ver <= 4 ) || $high2 <= 5 ) &&
         $low >= 0x01 && $low <= 0x5A ) {
        # Vodafone の絵文字は特殊なエスケープシーケンス
        my $map = [qw( G E F O P Q )];
        $str = sprintf( "\e\x24%s%c\x0F",$map->[$high2],$low+0x20);
    }
    $str;
}
# -------------------------------------------------------------------- #
#   EZweb 絵文字は5ブロックに分かれる
#
#   EZweb       UNICODE     JIS         OFFSET
#     1～334    E468～E5B4  7521～7853  50576差
#   335～376    E5B5～E5DF  7867～7933  50557差
#   377～499    EA80～EAFA  7934～7A50  51741差
#   500～518    EAFB～EB0D  7854～7866  51926差
#   700～822    EB0E～EB88  7A51～7B6D  51760差
#
#   JIS コードから UNICODE を求める式
#       UCS2 = (JH-33) * 94 + (JL-33) + OFFSET
#
#   UNICODE から JIS コードを求める式
#       JH = ((UCS2-OFFSET)/94)+33
#       JL = ((UCS2-OFFSET)%94)+33
# -------------------------------------------------------------------- #
sub one_unescape_ezweb {
    my $ucs2 = shift or return;
    my $str;

    my $offset;
    if ( $ucs2 >= 0xE468 && $ucs2 <= 0xE5B4 ) {
        $offset = 50576;
    } elsif ( $ucs2 >= 0xE5B5 && $ucs2 <= 0xE5DF ) {
        $offset = 50557;
    } elsif ( $ucs2 >= 0xEA80 && $ucs2 <= 0xEAFA ) {
        $offset = 51741;
    } elsif ( $ucs2 >= 0xEAFB && $ucs2 <= 0xEB0D ) {
        $offset = 51926;
    } elsif ( $ucs2 >= 0xEB0E && $ucs2 <= 0xEB88 ) {
        $offset = 51760;
    }

    if ( $offset ) {
        my $jh = int(($ucs2 - $offset )/94) + 33;
        my $jl = (($ucs2 - $offset )%94) + 33;
        $str = $JISBEG.pack("C*"=>$jh, $jl).$JISEND;
    }

    $str;
}
# -------------------------------------------------------------------- #
sub require_mime_base64 {
    if ( ! defined $MIME::Base64::VERSION ) {
        eval 'require "MIME/Base64.pm";';
    }
    if ( ! defined $MIME::Base64::VERSION ) {
        die "MIME::Base64 is required for EscapeSJIS::mime_encode()\n";
    }
}
# -------------------------------------------------------------------- #
;1; # End of the script.
# -------------------------------------------------------------------- #