[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/i586-linux-thread-multi/Encode/JP/ -> JIS7.pm (source)

   1  package Encode::JP::JIS7;
   2  use strict;
   3  use warnings;
   4  our $VERSION = do { my @r = ( q$Revision: 2.3 $ =~ /\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} = bless {
  13          Name    => $name,
  14          h2z     => $h2z,
  15          jis0212 => $jis0212,
  16      } => __PACKAGE__;
  17  }
  18  
  19  use base qw(Encode::Encoding);
  20  
  21  # we override this to 1 so PerlIO works
  22  sub needs_lines { 1 }
  23  
  24  use Encode::CJKConstants qw(:all);
  25  
  26  #
  27  # decode is identical for all 2022 variants
  28  #
  29  
  30  sub decode($$;$) {
  31      my ( $obj, $str, $chk ) = @_;
  32      my $residue = '';
  33      if ($chk) {
  34          $str =~ s/([^\x00-\x7f].*)$//so and $residue = $1;
  35      }
  36      $residue .= jis_euc( \$str );
  37      $_[1] = $residue if $chk;
  38      return Encode::decode( 'euc-jp', $str, FB_PERLQQ );
  39  }
  40  
  41  #
  42  # encode is different
  43  #
  44  
  45  sub encode($$;$) {
  46      require Encode::JP::H2Z;
  47      my ( $obj, $utf8, $chk ) = @_;
  48  
  49      # empty the input string in the stack so perlio is ok
  50      $_[1] = '' if $chk;
  51      my ( $h2z, $jis0212 ) = @$obj{qw(h2z jis0212)};
  52      my $octet = Encode::encode( 'euc-jp', $utf8, $chk );
  53      $h2z and &Encode::JP::H2Z::h2z( \$octet );
  54      euc_jis( \$octet, $jis0212 );
  55      return $octet;
  56  }
  57  
  58  #
  59  # cat_decode
  60  #
  61  my $re_scan_jis_g = qr{
  62     \G ( ($RE{JIS_0212}) |  $RE{JIS_0208}  |
  63          ($RE{ISO_ASC})  | ($RE{JIS_KANA}) | )
  64        ([^\e]*)
  65  }x;
  66  
  67  sub cat_decode {    # ($obj, $dst, $src, $pos, $trm, $chk)
  68      my ( $obj, undef, undef, $pos, $trm ) = @_;    # currently ignores $chk
  69      my ( $rdst, $rsrc, $rpos ) = \@_[ 1, 2, 3 ];
  70      local ${^ENCODING};
  71      use bytes;
  72      my $opos = pos($$rsrc);
  73      pos($$rsrc) = $pos;
  74      while ( $$rsrc =~ /$re_scan_jis_g/gc ) {
  75          my ( $esc, $esc_0212, $esc_asc, $esc_kana, $chunk ) =
  76            ( $1, $2, $3, $4, $5 );
  77  
  78          unless ($chunk) { $esc or last; next; }
  79  
  80          if ( $esc && !$esc_asc ) {
  81              $chunk =~ tr/\x21-\x7e/\xa1-\xfe/;
  82              if ($esc_kana) {
  83                  $chunk =~ s/([\xa1-\xdf])/\x8e$1/og;
  84              }
  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 =~ s/\Q$ESC{ASC}\E
 152          (\Q$ESC{KANA}\E|\Q$ESC{JIS_0212}\E|\Q$ESC{JIS_0208}\E)/$1/gox;
 153      $$r_str;
 154  }
 155  
 156  1;
 157  __END__
 158  
 159  
 160  =head1 NAME
 161  
 162  Encode::JP::JIS7 -- internally used by Encode::JP
 163  
 164  =cut


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1