Upgrade to Encode 0.98, from Dan Kogai.
[p5sagit/p5-mst-13.2.git] / ext / Encode / lib / Encode / JP / JIS.pm
1 package Encode::JP::JIS;
2 use Encode::JP;
3 use base 'Encode::Encoding';
4
5 use strict;
6
7 use vars qw($VERSION);
8 $VERSION = do { my @r = (q$Revision: 0.98 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
9
10 # Just for the time being, we implement jis-7bit
11 # encoding via EUC
12
13 my $canon = '7bit-jis';
14 my $obj = bless {name => $canon}, __PACKAGE__;
15 $obj->Define($canon);
16
17 sub name { return $_[0]->{name}; }
18
19 sub decode
20 {
21     my ($obj,$str,$chk) = @_;
22     my $res = $str;
23     jis_euc(\$res);
24     return Encode::decode('euc-jp', $res, $chk);
25 }
26
27 sub encode
28 {
29     my ($obj,$str,$chk) = @_;
30     my $res = Encode::encode('euc-jp', $str, $chk);
31     euc_jis(\$res);
32     return $res;
33 }
34
35 use Encode::JP::Constants qw(:all);
36
37 # JIS<->EUC
38
39 sub jis_euc {
40     my $r_str = shift;
41     $$r_str =~ s(
42                  ($RE{JIS_0212}|$RE{JIS_0208}|$RE{JIS_ASC}|$RE{JIS_KANA})
43                  ([^\e]*)
44                  )
45     {
46         my ($esc, $str) = ($1, $2);
47         if ($esc !~ /$RE{JIS_ASC}/o) {
48             $str =~ tr/\x21-\x7e/\xa1-\xfe/;
49             if ($esc =~ /$RE{JIS_KANA}/o) {
50                 $str =~ s/([\xa1-\xdf])/\x8e$1/og;
51             }
52             elsif ($esc =~ /$RE{JIS_0212}/o) {
53                 $str =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og;
54             }
55         }
56         $str;
57     }geox;
58     $$r_str;
59 }
60
61 sub euc_jis{
62     my $r_str = shift;
63     $$r_str =~ s{
64         ((?:$RE{EUC_C})+|(?:$RE{EUC_KANA})+|(?:$RE{EUC_0212})+)
65         }{
66             my $str = $1;
67             my $esc = 
68                 ( $str =~ tr/\x8E//d ) ? $ESC{KANA} :
69                     ( $str =~ tr/\x8F//d ) ? $ESC{JIS_0212} :
70                         $ESC{JIS_0208};
71             $str =~ tr/\xA1-\xFE/\x21-\x7E/;
72             $esc . $str . $ESC{ASC};
73         }geox;
74     $$r_str =~
75         s/\Q$ESC{ASC}\E
76             (\Q$ESC{KANA}\E|\Q$ESC{JIS_0212}\E|\Q$ESC{JIS_0208}\E)/$1/gox;
77     $$r_str;
78 }
79
80 sub euc_jis_nox0212{
81     my $r_str = shift;
82     $$r_str =~ s/$RE{EUC_0212}/$CHARCODE{UNDEF_EUC}/go;
83     euc_jis($r_str);
84 }
85
86 1;
87 __END__