"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/Encode/JP/JIS7.pm" (10 Mar 2019, 4262 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package Encode::JP::JIS7;
    2 use strict;
    3 use warnings;
    4 our $VERSION = do { my @r = ( q$Revision: 2.8 $ =~ /\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     my $obj = bless {
   13         Name    => $name,
   14         h2z     => $h2z,
   15         jis0212 => $jis0212,
   16     } => __PACKAGE__;
   17     Encode::define_encoding($obj, $name);
   18 }
   19 
   20 use parent 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     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 
   47 sub 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 #
   64 my $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 
   70 sub 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
  108 my $re_scan_jis = qr{
  109    (?:($RE{JIS_0212})|$RE{JIS_0208}|($RE{ISO_ASC})|($RE{JIS_KANA}))([^\e]*)
  110 }x;
  111 
  112 sub 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 
  134 sub 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 
  160 1;
  161 __END__
  162 
  163 
  164 =head1 NAME
  165 
  166 Encode::JP::JIS7 -- internally used by Encode::JP
  167 
  168 =cut