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