ext/Encode/lib/Encode/JP/JIS7.pm

   1 package Encode::JP::JIS7;
   2 use strict;
   3
   4 our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
   5
   6 use Encode qw(:fallbacks);
   7
   8 for my $name ('7bit-jis', 'iso-2022-jp', 'iso-2022-jp-1'){
   9     my $h2z     = ($name eq '7bit-jis')    ? 0 : 1;
  10     my $jis0212 = ($name eq 'iso-2022-jp') ? 0 : 1;
  11
  12     $Encode::Encoding{$name} =
  13         bless {
  14                Name      =>   $name,
  15                h2z       =>   $h2z,
  16                jis0212   =>   $jis0212,
  17               } => __PACKAGE__;
  18 }
  19
  20 use base qw(Encode::Encoding);
  21
  22 # we override this to 1 so PerlIO works
  23 sub needs_lines { 1 }
  24
  25 use Encode::CJKConstants qw(:all);
  26
  27 #
  28 # decode is identical for all 2022 variants
  29 #
  30
  31 sub decode($$;$)
  32 {
  33     my ($obj, $str, $chk) = @_;
  34     my $residue = '';
  35     if ($chk){
  36         $str =~ s/([^\x00-\x7f].*)$//so and $residue = $1;
  37     }
  38     $residue .= jis_euc(\$str);
  39     $_[1] = $residue if $chk;
  40     return Encode::decode('euc-jp', $str, FB_PERLQQ);
  41 }
  42
  43 #
  44 # encode is different
  45 #
  46
  47 sub encode($$;$)
  48 {
  49     require Encode::JP::H2Z;
  50     my ($obj, $utf8, $chk) = @_;
  51     # empty the input string in the stack so perlio is ok
  52     $_[1] = '' if $chk;
  53     my ($h2z, $jis0212) = @$obj{qw(h2z jis0212)};
  54     my $octet = Encode::encode('euc-jp', $utf8, FB_PERLQQ) ;
  55     $h2z and &Encode::JP::H2Z::h2z(\$octet);
  56     euc_jis(\$octet, $jis0212);
  57     return $octet;
  58 }
  59
  60 #
  61 # cat_decode
  62 #
  63 my $re_scan_jis_g = qr{
  64    \G ( ($RE{JIS_0212}) |  $RE{JIS_0208}  |
  65         ($RE{ISO_ASC})  | ($RE{JIS_KANA}) | )
  66       ([^\e]*)
  67 }x;
  68 sub cat_decode { # ($obj, $dst, $src, $pos, $trm, $chk)
  69     my ($obj, undef, undef, $pos, $trm) = @_; # currently ignores $chk
  70     my ($rdst, $rsrc, $rpos) = \@_[1,2,3];
  71     local ${^ENCODING};
  72     use bytes;
  73     my $opos = pos($$rsrc);
  74     pos($$rsrc) = $pos;
  75     while ($$rsrc =~ /$re_scan_jis_g/gc) {
  76         my ($esc, $esc_0212, $esc_asc, $esc_kana, $chunk) =
  77           ($1, $2, $3, $4, $5);
  78
  79         unless ($chunk) { $esc or last;  next; }
  80
  81         if ($esc && !$esc_asc) {
  82             $chunk =~ tr/\x21-\x7e/\xa1-\xfe/;
  83             if ($esc_kana) {
  84                 $chunk =~ s/([\xa1-\xdf])/\x8e$1/og;
  85             } elsif ($esc_0212) {
  86                 $chunk =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og;
  87             }
  88             $chunk = Encode::decode('euc-jp', $chunk, 0);
  89         }
  90         elsif ((my $npos = index($chunk, $trm)) >= 0) {
  91             $$rdst .= substr($chunk, 0, $npos + length($trm));
  92             $$rpos += length($esc) + $npos + length($trm);
  93             pos($$rsrc) = $opos;
  94             return 1;
  95         }
  96         $$rdst .= $chunk;
  97         $$rpos = pos($$rsrc);
  98     }
  99     $$rpos = pos($$rsrc);
 100     pos($$rsrc) = $opos;
 101     return '';
 102 }
 103
 104 # JIS<->EUC
 105 my $re_scan_jis = qr{
 106    (?:($RE{JIS_0212})|$RE{JIS_0208}|($RE{ISO_ASC})|($RE{JIS_KANA}))([^\e]*)
 107 }x;
 108
 109 sub jis_euc {
 110     local ${^ENCODING};
 111     my $r_str = shift;
 112     $$r_str =~ s($re_scan_jis)
 113     {
 114         my ($esc_0212, $esc_asc, $esc_kana, $chunk) =
 115            ($1, $2, $3, $4);
 116         if (!$esc_asc) {
 117             $chunk =~ tr/\x21-\x7e/\xa1-\xfe/;
 118             if ($esc_kana) {
 119                 $chunk =~ s/([\xa1-\xdf])/\x8e$1/og;
 120             }
 121             elsif ($esc_0212) {
 122                 $chunk =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og;
 123             }
 124         }
 125         $chunk;
 126     }geox;
 127     my ($residue) = ($$r_str =~ s/(\e.*)$//so);
 128     return $residue;
 129 }
 130
 131 sub euc_jis{
 132     no warnings qw(uninitialized);
 133     my $r_str = shift;
 134     my $jis0212 = shift;
 135     $$r_str =~ s{
 136         ((?:$RE{EUC_C})+|(?:$RE{EUC_KANA})+|(?:$RE{EUC_0212})+)
 137         }{
 138             my $chunk = $1;
 139             my $esc =
 140                 ( $chunk =~ tr/\x8E//d ) ? $ESC{KANA} :
 141                     ( $chunk =~ tr/\x8F//d ) ? $ESC{JIS_0212} :
 142                         $ESC{JIS_0208};
 143             if ($esc eq $ESC{JIS_0212} && !$jis0212){
 144                 # fallback to '?'
 145                 $chunk =~ tr/\xA1-\xFE/\x3F/;
 146             }else{
 147                 $chunk =~ tr/\xA1-\xFE/\x21-\x7E/;
 148             }
 149             $esc . $chunk . $ESC{ASC};
 150         }geox;
 151     $$r_str =~
 152         s/\Q$ESC{ASC}\E
 153             (\Q$ESC{KANA}\E|\Q$ESC{JIS_0212}\E|\Q$ESC{JIS_0208}\E)/$1/gox;
 154     $$r_str;
 155 }
 156
 157 1;
 158 __END__
 159
 160
 161 =head1 NAME
 162
 163 Encode::JP::JIS7 -- internally used by Encode::JP
 164
 165 =cut