/[suikacvs]/perl/lib/Encode/ISO2022.pm

Diff of /perl/lib/Encode/ISO2022.pm

Parent Directory | Revision Log | View Patch Patch

-revision 1.3 by wakaba,
Mon Sep 16 02:20:18 2002 UTC
+revision 1.9 by wakaba,
Mon Oct 14 06:58:35 2002 UTC
 Line 3
  Encode::ISO2022 --- ISO/IEC 2022 encoder and decoder
+ =head1 ENCODINGS
+ =over 4
+ =item iso2022
+ ISO/IEC 2022:1994.  Default status is:
+ =over 2
+ =item CL = C0 = ISO/IEC 6429:1991 C0 set
+ =item CR = C1 = ISO/IEC 6429:1991 C1 set
+ =item GL = G0 = ISO/IEC 646:1991 IRV GL(G0) set
+ =item GR = G1 = empty set
+ =item G2 = empty set
+ =item G3 = empty set
+ =back
+ (Alias: iso/iec2022, iso-2022, 2022, cp2022)
+ =back
+ Note that ISO/IEC 2022 based encodings are found in
+ Encode::ISO2022::* modules.  This module, Encode::ISO2022
+ only provides a general ISO/IEC 2022 encoder/decoder.
  =cut
  require v5.7.3;
  package Encode::ISO2022;
  use strict;
- use vars qw(%CHARSET $VERSION);
+ use vars qw(%CHARSET %CODING_SYSTEM $VERSION);
  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
  use base qw(Encode::Encoding);
- __PACKAGE__->Define (qw/iso-2022 iso2022 2022 cp2022/);
+ __PACKAGE__->Define (qw!iso-2022 iso/iec2022 iso2022 2022 cp2022!);
+ require Encode::Charset;
- ### --- Intialization
+         *CHARSET = \%Encode::Charset::CHARSET;
+         *CODING_SYSTEM = \%Encode::Charset::CODING_SYSTEM;
- my %_CHARS_to_RANGE = (
-         l94     => q/[\x21-\x7E]/,
-         l96     => q/[\x20-\x7F]/,
-         l128    => q/[\x00-\x7F]/,
-         l256    => q/[\x00-\xFF]/,
-         r94     => q/[\xA1-\xFE]/,
-         r96     => q/[\xA0-\xFF]/,
-         r128    => q/[\x80-\xFF]/,
-         r256    => q/[\x80-\xFF]/,
-         b94     => q/[\x21-\x7E\xA1-\xFE]/,
-         b96     => q/[\x20-\x7F\xA0-\xFF]/,
-         b128    => q/[\x00-\xFF]/,
-         b256    => q/[\x00-\xFF]/,
- );
- ## --- Make initial charset definitions
- &_make_initial_charsets;
- sub _make_initial_charsets () {
- for my $f (0x30..0x7E) {
-   my $F = pack 'C', $f;
-   for ('', '!', '"', '#') {
-     $CHARSET{G94}->{ $_.$F }->{dimension} = 1;
-     $CHARSET{G94}->{ $_.$F }->{chars} = 94;
-     $CHARSET{G94}->{ $_.$F }->{ucs} =
-       {'' => 0xE90940, '!' => 0xE944A0, '"' => 0xE98000, '#' => 0xE9BB60}->{ $_ }
-       + 94 * ($f-0x30);
-     $CHARSET{G96}->{ $_.$F }->{dimension} = 1;
-     $CHARSET{G96}->{ $_.$F }->{chars} = 96;
-     $CHARSET{G96}->{ $_.$F }->{ucs} =
-       {'' => 0xE926A0, '!' => 0xE96200, '"' => 0xE99D60, '#' => 0xE9D8C0}->{ $_ }
-       + 96 * ($f-0x30);
-     $CHARSET{C0}->{ $_.$F }->{dimension} = 1;
-     $CHARSET{C0}->{ $_.$F }->{chars} = 32;
-     $CHARSET{C0}->{ $_.$F }->{ucs} =
-       {'' => 0x70000000, '!' => 0x70001400,
-       '"' => 0x70002800, '#' => 0x70003C00}->{ $_ } + 32 * ($f-0x30);
-     $CHARSET{C1}->{ $_.$F }->{dimension} = 1;
-     $CHARSET{C1}->{ $_.$F }->{chars} = 32;
-     $CHARSET{C1}->{ $_.$F }->{ucs} =
-       {'' => 0x70000A00, '!' => 0x70001E00,
-       '"' => 0x70003200, '#' => 0x70004600}->{ $_ } + 32 * ($f-0x30);
-     $CHARSET{G94}->{ ' '.$_.$F }->{dimension} = 1;      ## DRCS
-     $CHARSET{G94}->{ ' '.$_.$F }->{chars} = 94;
-     $CHARSET{G94}->{ ' '.$_.$F }->{ucs} =
-       {'' => 0x70090940, '!' => 0x700944A0,
-       '"' => 0x70098000, '#' => 0x7009BB60}->{ $_ } + 94 * ($f-0x30);
-     $CHARSET{G96}->{ ' '.$_.$F }->{dimension} = 1;      ## DRCS
-     $CHARSET{G96}->{ ' '.$_.$F }->{chars} = 96;
-     $CHARSET{G96}->{ ' '.$_.$F }->{ucs} =
-       {'' => 0x700926A0, '!' => 0x70096200,
-       '"' => 0x70099D60, '#' => 0x7009D8C0}->{ $_ } + 96 * ($f-0x30);
-   }
- }
- for my $f (0x30..0x5F, 0x7E) {
-   my $F = pack 'C', $f;
-   for ('', '!', '"', '#', ' ') {
-     $CHARSET{G94n}->{ $_.$F }->{dimension} = 2;
-     $CHARSET{G94n}->{ $_.$F }->{chars} = 94;
-     $CHARSET{G94n}->{ $_.$F }->{ucs} =
-       ({'' => 0xE9F6C0}->{ $_ }||0) + 94*94 * ($f-0x30);
-       ## BUG: 94^n sets with I byte have no mapping area
-     $CHARSET{G96n}->{ $_.$F }->{dimension} = 2;
-     $CHARSET{G96n}->{ $_.$F }->{chars} = 96;
-     $CHARSET{G96n}->{ $_.$F }->{ucs} =
-       ({'' => 0xF4C000}->{ $_ }||0) + 96*96 * ($f-0x30);
-       ## BUG: 94^n DRCSes with I byte have no mapping area
-   }
- }
- for (0x60..0x6F) {
-   my $F = pack 'C', $_;
-   ## BUG: 9x^3 sets have no mapping area
-   for ('', '!', '"', '#', ' ') {
-     $CHARSET{G94n}->{ $_.$F }->{dimension} = 3;
-     $CHARSET{G94n}->{ $_.$F }->{chars} = 94;
-     $CHARSET{G96n}->{ $_.$F }->{dimension} = 3;
-     $CHARSET{G96n}->{ $_.$F }->{chars} = 96;
-   }
- }
- for (0x70..0x7D) {
-   my $F = pack 'C', $_;
-   ## BUG: 9x^4 sets have no mapping area
-   for ('', '!', '"', '#', ' ') {
-     $CHARSET{G94n}->{ $_.$F }->{dimension} = 4;
-     $CHARSET{G94n}->{ $_.$F }->{chars} = 94;
-     $CHARSET{G96n}->{ $_.$F }->{dimension} = 4;
-     $CHARSET{G96n}->{ $_.$F }->{chars} = 96;
-   }
- }
- for my $f (0x40..0x4E) {
-   my $F = pack 'C', $f;
-     $CHARSET{G96n}->{ ' '.$F }->{dimension} = 2;
-     $CHARSET{G96n}->{ ' '.$F }->{chars} = 96;
-     $CHARSET{G96n}->{ ' '.$F }->{ucs} = 0xF0000 + 96*96*($f-0x40);
-     ## U+F0000-U+10F7FF (private) -> ESC 02/04 02/00 <I> (04/00-04/14) (DRCS)
- }
- $CHARSET{G94}->{B}->{ucs} = 0x21;       ## ASCII
- $CHARSET{G96}->{A}->{ucs} = 0xA0;       ## ISO 8859-1
- $CHARSET{G94n}->{'B@'}->{dimension} = 2;        ## JIS X 0208-1990
- $CHARSET{G94n}->{'B@'}->{chars} = 94;
- $CHARSET{G94n}->{'B@'}->{ucs} = 0xE9F6C0 + 94*94*79;
-   ## -- Control character sets
-   $CHARSET{C0}->{'@'}->{ucs} = 0x00;    ## ISO/IEC 6429 C0
-   for ("\x40", "\x43", "\x44", "\x45", "\x46", "\x49", "\x4A", "\x4B", "\x4C") {
-     $CHARSET{C0}->{$_}->{C_LS0} = "\x0F";
-     $CHARSET{C0}->{$_}->{C_LS1} = "\x0E";
-     $CHARSET{C0}->{$_}->{r_LS0} = '\x0F';
-     $CHARSET{C0}->{$_}->{r_LS1} = '\x0E';
-   }
-   for ("\x40", "\x44", "\x45", "\x46", "\x48", "\x4C") {
-     $CHARSET{C0}->{$_}->{reset_all} = {"\x0A" => 1, "\x0B" => 1,
-       "\x0C" => 1, "\x0D" => 1};
-   }
-   $CHARSET{C0}->{"\x43"}->{reset_all} = {"\x0A" => 1};
-   $CHARSET{C0}->{"\x44"}->{C_SS2} = "\x1C";
-   $CHARSET{C0}->{"\x44"}->{r_SS2} = '\x1C';
-   for ("\x45", "\x49", "\x4A", "\x4B") {
-     $CHARSET{C0}->{$_}->{C_SS2} = "\x19";
-     $CHARSET{C0}->{$_}->{C_SS3} = "\x1D";
-     $CHARSET{C0}->{$_}->{r_SS2} = '\x19';
-     $CHARSET{C0}->{$_}->{r_SS3} = '\x1D';
-   }
-   $CHARSET{C0}->{"\x4C"}->{C_SS2} = "\x19";
-   $CHARSET{C0}->{"\x4C"}->{r_SS2} = '\x19';
-   $CHARSET{C1}->{'64291991C1'}->{dimension} = 1;        ## ISO/IEC 6429:1991 C1
-   $CHARSET{C1}->{'64291991C1'}->{chars} = 32;
-   $CHARSET{C1}->{'64291991C1'}->{ucs} = 0x80;
-   for ("\x43", "\x45", "\x47", '64291991C1') {
-     $CHARSET{C1}->{$_}->{C_SS2} = "\x8E";
-     $CHARSET{C1}->{$_}->{C_SS3} = "\x8F";
-     $CHARSET{C1}->{$_}->{r_SS2} = '\x8E';
-     $CHARSET{C1}->{$_}->{r_SS3} = '\x8F';
-     $CHARSET{C1}->{$_}->{r_SS2_ESC} = '\x1B\x4E';
-     $CHARSET{C1}->{$_}->{r_SS3_ESC} = '\x1B\x4F';
-   }
-   for ("\x43", '64291991C1') {
-     $CHARSET{C1}->{$_}->{r_CSI} = '\x9B';
-     $CHARSET{C1}->{$_}->{r_CSI_ESC} = '\x1B\x5B';
-     $CHARSET{C1}->{$_}->{r_DCS} = '\x90';
-     $CHARSET{C1}->{$_}->{r_ST} = '\x9C';
-     $CHARSET{C1}->{$_}->{r_OSC} = '\x9D';
-     $CHARSET{C1}->{$_}->{r_PM} = '\x9E';
-     $CHARSET{C1}->{$_}->{r_APC} = '\x9F';
-     $CHARSET{C1}->{$_}->{reset_all} = {"\x85"=>1, "\x90"=>1,
-       "\x9C"=>1, "\x9D"=>1, "\x9E"=>1, "\x9F"=>1};
-   }
-   $CHARSET{C1}->{'64291991C1'}->{r_SCI} = '\x9A';
-   $CHARSET{single_control}->{Fs}   ={ucs => 0x70005000, chars => 32, dimension => 1};
-   $CHARSET{single_control}->{'3F'} ={ucs => 0x70005020, chars => 80, dimension => 1};
-   $CHARSET{single_control}->{'3F!'}={ucs => 0x70005070, chars => 80, dimension => 1};
-   $CHARSET{single_control}->{'3F"'}={ucs => 0x700050C0, chars => 80, dimension => 1};
-   $CHARSET{single_control}->{'3F#'}={ucs => 0x70005110, chars => 80, dimension => 1};
- }
  ### --- Perl Encode module common functions
-Line 198 
 sub decode ($$;$) {
+Line 64 
 sub decode ($$;$) {
  }
  ### --- Encode::ISO2022 unique functions
+ *new_object = \&Encode::Charset::new_object;
- ## Make a new ISO/IEC 2022-buffers object with default status
- sub new_object {
-   my %C;
-   $C{bit} = 8;
-   $C{CL} = 'C0'; $C{CR} = 'C1'; $C{ESC_Fe} = 'C1';
-   $C{C0} = $CHARSET{C0}->{"\x40"};      ## ISO/IEC 6429:1991 C0
-   $C{C1} = $CHARSET{C1}->{'64291991C1'};        ## ISO/IEC 6429:1991 C1
-   $C{GL} = 'G0'; $C{GR} = 'G1';
-   $C{G0} = $CHARSET{G94}->{"\x42"};     ## ISO/IEC 646:1991 IRV
-   #$C{G1} = $CHARSET{G96}->{"\x41"};    ## ISO/IEC 8859-1 GR
-   $C{G1} = $CHARSET{G94}->{"\x7E"};     ## empty set
-   $C{G2} = $CHARSET{G94}->{"\x7E"};     ## empty set
-   $C{G3} = $CHARSET{G94}->{"\x7E"};     ## empty set
-   $C{option} = {
-         C1invoke_to_right       => 0,   ## C1 invoked to: (0: ESC Fe, 1: CR)
-         G94n_designate_long     => 0,   ## (1: ESC 02/04 02/08 04/00..02)
-         designate_to    => {    ## Designated G buffer (-1: not be outputed)
-                 C0      => {
-                         default => 0,
-                 },
-                 C1      => {
-                         default => 1,
-                 },
-                 G94     => {
-                         "\x42"  => 0,
-                         default => 0,
-                 },
-                 G96     => {
-                         default => 1,
-                 },
-                 G94n    => {
-                         default => 0,
-                 },
-                 G96n    => {
-                         default => 1,
-                 },
-         },
-         Ginvoke_by_single_shift => [0,0,0,0],   ## Invoked by SS
-         Ginvoke_to_left => [1,1,1,1],   ## Which invoked to? (1: L, 0: R)
-         private_set     => {    ## Private set vs Final byte
-                 C0      => [],
-                 C1      => [],
-                 G94     => [],
-                 G94n    => [[],[],[],[],[]],
-                 G96     => [],
-                 #G96n   => [],  ## (not implemented)
-                 U96n    => [],  ## mule-unicode sets
-                 XC1     => {
-                         '64291991C1'    => undef,       ## ISO/IEC 6429:1991 C1
-                 },
-         },
-         reset => {      ## Reset status at top of line
-                 Gdesignation    => "\x42",      ## F of designation or 0
-                 Ginvoke => 1,
-         },
-         use_revision    => 1,   ## Output IRR
-   };
-   \%C;
- }
  sub iso2022_to_internal ($;\%) {
    my ($s, $C) = @_;
+   $C ||= &new_object;
+   my $t = '';
+   $s =~ s{^((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)}{
+     my $i2 = $1;
+     $t = _iso2022_to_internal ($i2, $C);
+     '';
+   }es;
+   my $pad = '';
+   use re 'eval';
+   $s =~ s{
+      ## ISO/IEC 2022
+       (??{"$pad\x1B$pad\x25$pad\x40"})((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
+      ## UTF-8
+      |(??{"$pad\x1B$pad\x25$pad(?:\x47|\x2F$pad"."[\x47-\x49])"})
+        ((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
+      ## UCS-2, UTF-16
+      |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})([\x40\x43\x45\x4A-\x4C])
+        ((?:(?!\x00\x1B\x00\x25(?:\x00\x2F)?\x00[\x30-\x7E])..)*)
+      ## UCS-4
+      |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})[\x41\x44\x46]
+        ((?:(?!\x00\x00\x00\x1B\x00\x00\x00\x25(?:\x00\x00\x00\x2F)?
+            \x00\x00\x00[\x30-\x7E])....)*)
+      ## with standard return
+      |(??{"$pad\x1B$pad\x25$pad"})([\x30-\x7E])
+        ((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
+      ## without standard return
+      |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})([\x30-\x7E])(.*)
+   }{
+     my ($i2,$u8,$Fu2,$u2,$u4,$Fsr,$sr,$Fnsr,$nsr) = ($1,$2,$3,$4,$5,$6,$7,$8,$9);
+     my $r = '';
+     if (defined $i2) {
+       $r = _iso2022_to_internal ($i2, $C);  $pad = '';
+     } elsif (defined $u8) {
+       $r = Encode::decode ('utf8', $u8);  $pad = '';
+     } elsif ($Fu2) {
+       if (ord ($Fu2) > 0x49) {
+         $r = Encode::decode ('utf-16be', $u2);
+       } else {
+         $r = Encode::decode ('ucs-2be', $u2);
+       }
+       $pad = "\x00";
+     } elsif (defined $u4) {
+       $r = Encode::decode ('ucs-4be', $u2);  $pad = "\x00\x00\x00";
+     } elsif (defined $Fsr && $CODING_SYSTEM{$Fsr}->{perl_name}) {
+       $r = Encode::decode ($CODING_SYSTEM{$Fsr}->{perl_name}, $sr);  $pad = '';
+     } elsif (defined $Fnsr && $CODING_SYSTEM{$Fnsr}->{perl_name}) {
+       $r = Encode::decode ($CODING_SYSTEM{$Fnsr}->{perl_name}, $nsr);  $pad = '';
+     } else {    ## temporary
+       $r = '?' x length ($sr.$nsr);  $pad = '';
+     }
+     $r;
+   }gesx;
+   $t . $s;
+ }
+ # this is very very trickey.  my perl 5.8.0 does not process
+ # regex with eval except the first time (i think it's a bug
+ # of perl), so we redefine this function whenever being called!
+ # when this unexpected behavior is fixed or someone finds
+ # better way to avoid it, we will rewrite this code.
+ &_iso2022_to_internal (undef);
+ sub _iso2022_to_internal ($;\%) {
+   eval q{ sub __iso2022_to_internal ($;\%) { 0 } };
+   eval q{
+ sub __iso2022_to_internal ($;\%) {
+   use re 'eval';
+   my ($s, $C) = @_;
    my %_GB_to_GN = (
      "\x28"=>'G0',"\x29"=>'G1',"\x2A"=>'G2',"\x2B"=>'G3',
      "\x2C"=>'G0',"\x2D"=>'G1',"\x2E"=>'G2',"\x2F"=>'G3',
    );
-   $C ||= &new_object;
+   my %_CHARS_to_RANGE = (
+         l94     => q/[\x21-\x7E]/,      l96     => q/[\x20-\x7F]/,
+         l128    => q/[\x00-\x7F]/,      l256    => q/[\x00-\xFF]/,
+         r94     => q/[\xA1-\xFE]/,      r96     => q/[\xA0-\xFF]/,
+         r128    => q/[\x80-\xFF]/,      r256    => q/[\x80-\xFF]/,
+         b94     => q/[\x21-\x7E\xA1-\xFE]/,     b96     => q/[\x20-\x7F\xA0-\xFF]/,
+         b128    => q/[\x00-\xFF]/,      b256    => q/[\x00-\xFF]/,
+   );
-   use re 'eval';
    $s =~ s{
       ((??{ $_CHARS_to_RANGE{'l'.$C->{$C->{GL}}->{chars}}
           . qq/{$C->{$C->{GL}}->{dimension},$C->{$C->{GL}}->{dimension}}/ }))
-     |((??{ $_CHARS_to_RANGE{'r'.$C->{$C->{GL}}->{chars}}
+     |((??{ $_CHARS_to_RANGE{'r'.$C->{$C->{GR}}->{chars}}
-          . qq/{$C->{$C->{GR}}->{dimension},$C->{$C->{GR}}->{dimension}}/ }))
+          . qq/{$C->{$C->{GR}}->{dimension},$C->{$C->{GR}}->{dimension}}/  }))
      |  (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS2} || '(?!)')
               . ($C->{$C->{ESC_Fe}}->{r_SS2_ESC} ?
                   qq/|$C->{$C->{ESC_Fe}}->{r_SS2_ESC}/ : '')
-Line 282 
 sub iso2022_to_internal ($;\%) {
+Line 161 
 sub iso2022_to_internal ($;\%) {
               ||$C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9
               qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'')
          })
-       ((??{ $_CHARS_to_RANGE{'b'.$C->{$C->{GL}}->{chars}}
+       ((??{ $_CHARS_to_RANGE{'b'.$C->{G2}->{chars}}
-             . qq/{$C->{G2}->{dimension},$C->{G2}->{dimension}}/ }))
+          . qq/{$C->{G2}->{dimension},$C->{G2}->{dimension}}/ }))
      |  (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS3} || '(?!)')
               . ($C->{$C->{ESC_Fe}}->{r_SS3_ESC} ?
                  qq/|$C->{$C->{ESC_Fe}}->{r_SS3_ESC}/ : '')
-Line 292 
 sub iso2022_to_internal ($;\%) {
+Line 171 
 sub iso2022_to_internal ($;\%) {
              || $C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9
               qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'')
          })
-       ((??{ $_CHARS_to_RANGE{'b'.$C->{$C->{GL}}->{chars}}
+       ((??{ $_CHARS_to_RANGE{'b'.$C->{G3}->{chars}}
              . qq/{$C->{G3}->{dimension},$C->{G3}->{dimension}}/ }))
      ## Locking shift
-     |( \x1B[\x6E\x6F\x7C-\x7E]
+     |(  (??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' })
-        |(??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' })
         |(??{ $C->{$C->{CL}}->{r_LS1}||'(?!)' })
       )
-Line 412 
 sub iso2022_to_internal ($;\%) {
+Line 290 
 sub iso2022_to_internal ($;\%) {
                $C->{GL} = 'G2'; '';
              } elsif ($Fs eq "\x6F") {   ## LS3
                $C->{GL} = 'G3'; '';
-             } elsif ($Fs eq "\x7E") {   ## LS1R
+             } elsif ($Fs eq "\x7E" || $Fs eq "\x6B") {  ## LS1R
                $C->{GR} = 'G1';  $C->{GL} = 'G1' if $C->{bit} == 7; '';
-             } elsif ($Fs eq "\x7D") {   ## LS2R
+             } elsif ($Fs eq "\x7D" || $Fs eq "\x6C") {  ## LS2R
                $C->{GR} = 'G2';  $C->{GL} = 'G2' if $C->{bit} == 7; '';
-             } elsif ($Fs eq "\x7C") {   ## LS3R
+             } elsif ($Fs eq "\x7C" || $Fs eq "\x6D") {  ## LS3R
                $C->{GR} = 'G3';  $C->{GL} = 'G3' if $C->{bit} == 7; '';
              } else {
                chr ($CHARSET{single_control}->{Fs}->{ucs} + (ord ($Fs) - 0x60));
-Line 438 
 sub iso2022_to_internal ($;\%) {
+Line 316 
 sub iso2022_to_internal ($;\%) {
          $C->{GL} = 'G0'; '';
        } elsif ($ls eq $C->{$C->{CL}}->{LS1}) {
          $C->{GL} = 'G1'; '';
-       } elsif ($ls =~ /\x1B([\x6E\x6F])/) {
-         $C->{GL} = {"\x6E"=>2, "\x6F"=>3}->{$1}; '';
-       } elsif ($ls =~ /\x1B([\x7C-\x7E])/) {
-         $C->{GR} = {"\x7E"=>1, "\x7D"=>2, "\x7C"=>3}->{$1}; '';
        }
      ## Control sequence
      } elsif ($csi) {
-Line 450 
 sub iso2022_to_internal ($;\%) {
+Line 324 
 sub iso2022_to_internal ($;\%) {
        $csi =~ s/$C->{$C->{CL}}->{LS1}//g if $C->{$C->{CL}}->{LS1};
        "\x9B".$csi;
      }
-   }gex;
+   }gesx;
    $s;
- }
+ } # __iso2022_to_internal
+   };
+   &__iso2022_to_internal (@_) if defined $_[0];
+ } # _iso2022_to_internal
  sub internal_to_iso2022 ($\%) {
    my ($s, $C) = @_;
-Line 460 
 sub internal_to_iso2022 ($\%) {
+Line 339 
 sub internal_to_iso2022 ($\%) {
    my $r = '';
    for my $c (split //, $s) {
-     my $cc = ord $c;
+     my $cc = ord $c;  Encode::_utf8_off ($c);
      my $t;
      if ($cc <= 0x1F) {
        $t = _i2c ($c, $C, type => 'C0', charset => '@');
-Line 470 
 sub internal_to_iso2022 ($\%) {
+Line 349 
 sub internal_to_iso2022 ($\%) {
        $t = _i2g ($c, $C, type => 'G94', charset => 'B');
      } elsif ($cc <= 0x9F) {
        $t = _i2c ($c, $C, type => 'C1', charset_id => '64291991C1',
-         charset => $C->{private_set}->{XC1}->{'64291991C1'});
+         charset => $C->{option}->{private_set}->{XC1}->{'64291991C1'});
      } elsif ($cc <= 0xFF) {
        $t = _i2g (chr($cc-0x80), $C, type => 'G96', charset => 'A');
      } elsif ($cc <= 0x24FF) {
        my $c = $cc - 0x100;
-       my $final = $C->{private_set}->{U96n}->[0];
+       my $final = $C->{option}->{private_set}->{U96n}->[0];
        if (length $final) {
          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
            type => 'G96n', charset => $final);
        }
      } elsif ($cc <= 0x33FF) {
        my $c = $cc - 0x2500;
-       my $final = $C->{private_set}->{U96n}->[1];
+       my $final = $C->{option}->{private_set}->{U96n}->[1];
        if (length $final) {
          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
            type => 'G96n', charset => $final);
        }
      } elsif (0xE000 <= $cc && $cc <= 0xFFFF) {
        my $c = $cc - 0xE000;
-       my $final = $C->{private_set}->{U96n}->[2];
+       my $final = $C->{option}->{private_set}->{U96n}->[2];
        if (length $final) {
          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
            type => 'G96n', charset => $final);
-Line 555 
 sub internal_to_iso2022 ($\%) {
+Line 434 
 sub internal_to_iso2022 ($\%) {
      } elsif (0x70400000 <= $cc && $cc <= 0x7040FFED) {
        my $c = $cc - 0x70400000;
        $t = _i2g (chr(($c % 94)+0x21), $C, charset_id => 'P'.int ($c / 94),
-           type => 'G94', charset => $C->{private_set}->{G94}->[ $c / 94 ]);
+           type => 'G94', charset => $C->{option}->{private_set}->{G94}->[ $c / 94 ]);
      } elsif (0x70410000 <= $cc && $cc <= 0x7041FFBF) {
        my $c = $cc - 0x70410000;
        $t = _i2g (chr(($c % 96)+0x20), $C, charset_id => 'P'.int ($c / 96),
-           type => 'G96', charset => $C->{private_set}->{G96}->[ $c / 96 ]);
+           type => 'G96', charset => $C->{option}->{private_set}->{G96}->[ $c / 96 ]);
      } elsif (0x70420000 <= $cc && $cc <= 0x7046F19B) {
        my $c = $cc % 0x10000;
        $t = _i2g (chr((($c % 8836) / 94)+0x21).chr(($c % 94)+0x21), $C,
            type => 'G94n',
            charset_id => 'P'.int(($cc / 0x10000) - 0x7042).'_'.int($c / 8836),
-           charset => $C->{private_set}->{G94n}->[ ($cc / 0x10000) - 0x7042 ]
+           charset => $C->{option}->{private_set}->{G94n}
-                        ->[ $c / 8836 ]);
+                        ->[ ($cc / 0x10000) - 0x7042 ]->[ $c / 8836 ]);
+     }
+     if (defined $t) {
+       $t = _i2o ($t, $C, cs_F => "\x40")
+         if $C->{coding_system} ne $CODING_SYSTEM{"\x40"};
+     } else {
+       my $F;  my @F = qw~G /G /H /I  B  /A /D /F~;
+       push @F, qw~/J /K /L~ if $cc <= 0x10FFFF;
+       push @F, qw~/@ /C /E~ if $cc <= 0xFFFF;
+       for (@F) {
+         if (defined $C->{option}->{designate_to}->{coding_system}->{$_}
+             && $C->{option}->{designate_to}->{coding_system}->{$_} > -1) {
+           $F = $_; last;
+         } elsif ($C->{option}->{designate_to}->{coding_system}->{default} > -1) {
+           $F = $_; last;
+         }
+       }
+       $t = _i2o ($c, $C, cs_F => $F) if $F;
      }
      if (defined $t) {
        $r .= $t;
      } else {
-       $r .= _i2g ("\x3F", $C, type => 'G94', charset => 'B');
+       unless ($C->{option}->{undef_char}->[0] eq "\x20") {
+         $t = _i2g ($C->{option}->{undef_char}->[0], $C,
+                     %{ $C->{option}->{undef_char}->[1] });
+       } else {  ## SP
+         $t = _back2ascii ($C) . "\x20";
+       }
+       $r .= $C->{coding_system} eq $CODING_SYSTEM{"\x40"} ?
+             $t : _i2o ($t, $C, cs_F => "\x40");
      }
    }
    $r . _back2ascii ($C);
-Line 625 
 sub _i2c ($%%) {
+Line 528 
 sub _i2c ($%%) {
  sub _i2g ($%%) {
    my ($s, $C, %O) = @_;
    my $r = '';
-   my $set = $CHARSET{$O{type}}->{$O{charset}};
+   my $set = $CHARSET{$O{type}}->{$O{charset}.
+     ($O{revision}&&$C->{option}->{use_revision}?$O{revision}:'')};
    my $set0 = $CHARSET{$O{type}}->{$O{charset_id}};
    ## -- designate character set
    my $G = 0;
-Line 679 
 sub _i2g ($%%) {
+Line 583 
 sub _i2g ($%%) {
        } elsif ($C->{C0}->{'C_SS'.$G}) {
          $r .= _i2c ($C->{C0}->{'C_SS'.$G}, $C, type => 'C0') || return undef;
        } else {  ## Both C0 and C1 set do not have SS2/3.
+         $left = 0 if $G == 1 && !$C->{C0}->{C_LS1};
          $r .= __invoke ($C, $G => $left) if $C->{$left?'GL':'GR'} ne 'G'.$G;
        }
      } else {
-Line 725 
 sub __invoke (\%$$) {
+Line 630 
 sub __invoke (\%$$) {
    }
    '';
  }
+ sub _i2o ($\%%) {
- sub make_charset (%) {
+   my ($s, $C, %O) = @_;
- ## TODO: support private charset ID such as 'X0'
+   my $CS = $CODING_SYSTEM{ $O{cs_F} } || $CODING_SYSTEM{ $O{cs_id} } || return undef;
-   my %set = @_;
+   my $r = '';
-   my $setid = qq($set{I}$set{F}$set{revision});
+   if ($CS ne $C->{coding_system}) {
-   my $settype = $set{type} || 'G94';
+     my $e = '';
-   delete $set{type}, $set{I}, $set{F}, $set{revision};
+     $e .= "\x1B\x25";
-   $CHARSET{ $settype }->{ $setid } = \%set;
+     $e .= $O{cs_F} || $C->{option}->{private_set}->{coding_system}->{ $O{cs_id} }
+           || return undef;
+     if ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x40"}
+      || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x43"}
+      || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x45"}
+      || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4A"}
+      || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4B"}
+      || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4C"}) {
+       $e =~ s/(.)/\x00$1/go;
+     } elsif ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x41"}
+      || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x44"}
+      || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x46"}) {
+       $e =~ s/(.)/\x00\x00\x00$1/go;
+     }
+     $r .= $e;
+     $C->{coding_system} = $CS;
+     if ($CS->{reset_state}) {
+       $C->{GL} = undef;  $C->{GR} = undef;
+       $C->{C0} = $CHARSET{C0}->{"\x7E"};
+       $C->{C1} = $CHARSET{C1}->{"\x7E"};
+       $C->{G0} = $CHARSET{G94}->{"\x7E"};
+       $C->{G1} = $CHARSET{G94}->{"\x7E"};
+       $C->{G2} = $CHARSET{G94}->{"\x7E"};
+       $C->{G3} = $CHARSET{G94}->{"\x7E"};
+     }
+   }
+   if ($CS eq $CODING_SYSTEM{"\x40"}) {
+     #
+   } elsif ($CS eq $CODING_SYSTEM{G} || $CS eq $CODING_SYSTEM{'/G'}
+         || $CS eq $CODING_SYSTEM{'/H'} || $CS eq $CODING_SYSTEM{'/I'}) {
+     Encode::_utf8_off ($s);
+   } elsif ($CS eq $CODING_SYSTEM{'/@'} || $CS eq $CODING_SYSTEM{'/C'}
+         || $CS eq $CODING_SYSTEM{'/E'}) {
+     $s = Encode::encode ('ucs-2be', $s);
+   } elsif ($CS eq $CODING_SYSTEM{'/A'} || $CS eq $CODING_SYSTEM{'/D'}
+         || $CS eq $CODING_SYSTEM{'/F'}) {
+     $s = Encode::encode ('ucs-4be', $s);
+   } elsif ($CS eq $CODING_SYSTEM{'/J'} || $CS eq $CODING_SYSTEM{'/K'}
+         || $CS eq $CODING_SYSTEM{'/L'}) {
+     $s = Encode::encode ('UTF-16BE', $s);
+   } elsif ($CS eq $CODING_SYSTEM{B}) {
+     $s = Encode::encode ('utf-1', $s);
+   } else {
+     return undef;
+   }
+   $r . $s;
  }
 ;
-Line 755 
 ISO/IEC 8859, "8-Bit Single-Byte Coded G
+Line 705 
 ISO/IEC 8859, "8-Bit Single-Byte Coded G
  Encode, perlunicode
+ =head1 TODO
+ =over 4
+ =item NCR (coding system other than ISO/IEC 2022) support
+ =over 2
+ =item ESC 02/05 02/15 03/x of X Compound Text
+ =back
+ =item Output of control character sets, single control functions
+ =item Designation sequence of control character sets (input)
+ =item Special graphic character sets such as G3 of EUC-TW
+ =item SUPER SHIFT (SS) invoke function of old control character set
+ =item Safe transparent of control string (ISO/IEC 6429)
+ =item Output of unoutputable characters as alternative notation such as SGML-like entity
+ =item C0 set invoked to CR area like ISIRI code
+ Really need?
+ =item special treatment of 0x20, 0x7E, 0xA0, 0xFF
+ For example, GB mongolian sets use MSP (MONGOLIAN SPACE)
+ with these code positions.
+ And, no less coding systems does not use (or does ban using) DEL.
+ =item A lot of character sets don't have pseudo-UCS mapping.
+ Most of 9m^n (n >= 3) sets, 9m^n sets with I byte, 9m^n
+ DRCSes do not have pseudo-UCS mapping area.  It is
+ questionable to allocate lots of code positions to these
+ rarely-(or no-)used character sets.
+ =item Even character sets that have pseudo-UCS mapping, some of them can't be outputed in ISO/IEC 2022.
+ Because output of rarely-used character sets is
+ not implemented yet.
+ =back
+ =head1 AUTHORS
+ Nanashi-san
+ Wakaba <w@suika.fam.cx>
  =head1 LICENSE
- Copyright 2002 wakaba <w@suika.fam.cx>
+ Copyright 2002 AUTHORS
  This library is free software; you can redistribute it
  and/or modify it under the same terms as Perl itself.

 Legend:



Removed from v.1.3
 


changed lines


 
Added in v.1.9
 Legend:



Removed from v.1.3
 


changed lines


 
Added in v.1.9
-Removed from v.1.3
+Added in v.1.9

admin@suikawiki.org	ViewVC Help
Powered by ViewVC 1.1.24