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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by wakaba, Sun Sep 15 05:08:13 2002 UTC revision 1.14 by wakaba, Wed Dec 18 10:21:09 2002 UTC
# Line 3  Line 3 
3    
4  Encode::ISO2022 --- ISO/IEC 2022 encoder and decoder  Encode::ISO2022 --- ISO/IEC 2022 encoder and decoder
5    
6    =head1 ENCODINGS
7    
8    =over 4
9    
10    =item iso2022
11    
12    ISO/IEC 2022:1994.  Default status is:
13    
14    =over 2
15    
16    =item CL = C0 = ISO/IEC 6429:1991 C0 set
17    
18    =item CR = C1 = ISO/IEC 6429:1991 C1 set
19    
20    =item GL = G0 = ISO/IEC 646:1991 IRV GL(G0) set
21    
22    =item GR = G1 = empty set
23    
24    =item G2 = empty set
25    
26    =item G3 = empty set
27    
28    =back
29    
30    (Alias: iso/iec2022, iso-2022, 2022, cp2022)
31    
32    =back
33    
34    Note that ISO/IEC 2022 based encodings are found in
35    Encode::ISO2022::* modules.  This module, Encode::ISO2022
36    only provides a general ISO/IEC 2022 encoder/decoder.
37    
38  =cut  =cut
39    
40  require v5.7.3;  require v5.7.3;
41  package Encode::ISO2022;  package Encode::ISO2022;
42  use strict;  use strict;
43  use vars qw(%CHARSET $VERSION);  use vars qw(%CHARSET %CODING_SYSTEM $VERSION);
44  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
45  use base qw(Encode::Encoding);  use base qw(Encode::Encoding);
46  __PACKAGE__->Define (qw/iso-2022 iso2022 2022 cp2022/);  __PACKAGE__->Define (qw!iso-2022 iso/iec2022 iso2022 2022 cp2022!);
47    require Encode::Charset;
48  ### --- Intialization          *CHARSET = \%Encode::Charset::CHARSET;
49            *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 DRCSes 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};  
 }  
   
50    
51  ### --- Perl Encode module common functions  ### --- Perl Encode module common functions
52    
# Line 198  sub decode ($$;$) { Line 64  sub decode ($$;$) {
64  }  }
65    
66  ### --- Encode::ISO2022 unique functions  ### --- Encode::ISO2022 unique functions
67    *new_object = \&Encode::Charset::new_object;
68    
69  ## Make a new ISO/IEC 2022-buffers object with default status  sub iso2022_to_internal ($;%) {
70  sub new_object {    my ($s, $C) = @_;
71    my %C;    $C ||= &new_object;
72    $C{bit} = 8;    my $t = '';
73    $C{CL} = 'C0'; $C{CR} = 'C1'; $C{ESC_Fe} = 'C1';    $s =~ s{^((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)}{
74    $C{C0} = $CHARSET{C0}->{"\x40"};      ## ISO/IEC 6429:1991 C0      my $i2 = $1;
75    $C{C1} = $CHARSET{C1}->{'64291991C1'};        ## ISO/IEC 6429:1991 C1      $t = _iso2022_to_internal ($i2, $C);
76    $C{GL} = 'G0'; $C{GR} = 'G1';      '';
77    $C{G0} = $CHARSET{G94}->{"\x42"};     ## ISO/IEC 646:1991 IRV    }es;
78    #$C{G1} = $CHARSET{G96}->{"\x41"};    ## ISO/IEC 8859-1 GR    my $pad = '';
79    $C{G1} = $CHARSET{G94}->{"\x7E"};     ## empty set    use re 'eval';
80    $C{G2} = $CHARSET{G94}->{"\x7E"};     ## empty set    $s =~ s{
81    $C{G3} = $CHARSET{G94}->{"\x7E"};     ## empty set       ## ISO/IEC 2022
82    $C{option} = {        (??{"$pad\x1B$pad\x25$pad\x40"})((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
83          C1invoke_to_right       => 0,   ## C1 invoked to: (0: ESC Fe, 1: CR)       ## UTF-8
84          G94n_designate_long     => 0,   ## (1: ESC 02/04 02/08 04/00..02)       |(??{"$pad\x1B$pad\x25$pad(?:\x47|\x2F$pad"."[\x47-\x49])"})
85          designate_to    => {    ## Designated G buffer (-1: not be outputed)         ((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
86                  C0      => {       ## UCS-2, UTF-16
87                          default => 0,       |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})([\x40\x43\x45\x4A-\x4C])
88                  },         ((?:(?!\x00\x1B\x00\x25(?:\x00\x2F)?\x00[\x30-\x7E])..)*)
89                  C1      => {       ## UCS-4
90                          default => 1,       |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})[\x41\x44\x46]
91                  },         ((?:(?!\x00\x00\x00\x1B\x00\x00\x00\x25(?:\x00\x00\x00\x2F)?
92                  G94     => {             \x00\x00\x00[\x30-\x7E])....)*)
93                          "\x42"  => 0,       ## with standard return
94                          default => 0,       |(??{"$pad\x1B$pad\x25$pad"})([\x30-\x7E])
95                  },         ((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
96                  G96     => {       ## without standard return
97                          default => 1,       |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})([\x30-\x7E])(.*)
98                  },    }{
99                  G94n    => {      my ($i2,$u8,$Fu2,$u2,$u4,$Fsr,$sr,$Fnsr,$nsr) = ($1,$2,$3,$4,$5,$6,$7,$8,$9);
100                          default => 0,      my $r = '';
101                  },      if (defined $i2) {
102                  G96n    => {        $r = _iso2022_to_internal ($i2, $C);  $pad = '';
103                          default => 1,      } elsif (defined $u8) {
104                  },        $r = Encode::decode ('utf8', $u8);  $pad = '';
105          },      } elsif ($Fu2) {
106          Ginvoke_by_single_shift => [0,0,0,0],   ## Invoked by SS        if (ord ($Fu2) > 0x49) {
107          Ginvoke_to_left => [1,1,1,1],   ## Which invoked to? (1: L, 0: R)          $r = Encode::decode ('utf-16be', $u2);
108          private_set     => {    ## Private set vs Final byte        } else {
109                  C0      => [],          $r = Encode::decode ('ucs-2be', $u2);
110                  C1      => [],        }
111                  G94     => [],        $pad = "\x00";
112                  G94n    => [[],[],[],[],[]],      } elsif (defined $u4) {
113                  G96     => [],        $r = Encode::decode ('ucs-4be', $u2);  $pad = "\x00\x00\x00";
114                  #G96n   => [],  ## (not implemented)      } elsif (defined $Fsr && $CODING_SYSTEM{$Fsr}->{perl_name}) {
115                  U96n    => [],  ## mule-unicode sets        $r = Encode::decode ($CODING_SYSTEM{$Fsr}->{perl_name}, $sr);  $pad = '';
116                  XC1     => {      } elsif (defined $Fnsr && $CODING_SYSTEM{$Fnsr}->{perl_name}) {
117                          '64291991C1'    => undef,       ## ISO/IEC 6429:1991 C1        $r = Encode::decode ($CODING_SYSTEM{$Fnsr}->{perl_name}, $nsr);  $pad = '';
118                  },      } else {    ## temporary
119          },        $r = '?' x length ($sr.$nsr);  $pad = '';
120          reset => {      ## Reset status at top of line      }
121                  Gdesignation    => "\x42",      ## F of designation or 0      $r;
122                  Ginvoke => 1,    }gesx;
123          },    $t . $s;
124          use_revision    => 1,   ## Output IRR  }
125    };  
126    \%C;  # this is very very trickey.  my perl 5.8.0 does not process
127  }  # regex with eval except the first time (i think it's a bug
128    # of perl), so we redefine this function whenever being called!
129  sub iso2022_to_internal ($;\%) {  # when this unexpected behavior is fixed or someone finds
130    # better way to avoid it, we will rewrite this code.
131    &_iso2022_to_internal (undef);
132    sub _iso2022_to_internal ($;%) {
133      eval q{ sub __iso2022_to_internal ($;%) { 0 } };
134      eval q{
135    sub __iso2022_to_internal ($;%) {
136      use re 'eval';
137    my ($s, $C) = @_;    my ($s, $C) = @_;
138    my %_GB_to_GN = (    my %_GB_to_GN = (
139      "\x28"=>'G0',"\x29"=>'G1',"\x2A"=>'G2',"\x2B"=>'G3',      "\x28"=>'G0',"\x29"=>'G1',"\x2A"=>'G2',"\x2B"=>'G3',
140      "\x2C"=>'G0',"\x2D"=>'G1',"\x2E"=>'G2',"\x2F"=>'G3',      "\x2C"=>'G0',"\x2D"=>'G1',"\x2E"=>'G2',"\x2F"=>'G3',
141    );    );
142    $C ||= &new_object;    my %_CHARS_to_RANGE = (
143            l94     => q/[\x21-\x7E]/,      l96     => q/[\x20-\x7F]/,
144            l128    => q/[\x00-\x7F]/,      l256    => q/[\x00-\xFF]/,
145            r94     => q/[\xA1-\xFE]/,      r96     => q/[\xA0-\xFF]/,
146            r128    => q/[\x80-\xFF]/,      r256    => q/[\x80-\xFF]/,
147            b94     => q/[\x21-\x7E\xA1-\xFE]/,     b96     => q/[\x20-\x7F\xA0-\xFF]/,
148            b128    => q/[\x00-\xFF]/,      b256    => q/[\x00-\xFF]/,
149      );
150        
   use re 'eval';  
151    $s =~ s{    $s =~ s{
152       ((??{ $_CHARS_to_RANGE{'l'.$C->{$C->{GL}}->{chars}}       ((??{ $_CHARS_to_RANGE{'l'.$C->{$C->{GL}}->{chars}}
153           . qq/{$C->{$C->{GL}}->{dimension},$C->{$C->{GL}}->{dimension}}/ }))           . qq/{$C->{$C->{GL}}->{dimension},$C->{$C->{GL}}->{dimension}}/ }))
154      |((??{ $_CHARS_to_RANGE{'r'.$C->{$C->{GL}}->{chars}}      |((??{ $_CHARS_to_RANGE{'r'.$C->{$C->{GR}}->{chars}}
155           . qq/{$C->{$C->{GR}}->{dimension},$C->{$C->{GR}}->{dimension}}/ }))           . qq/{$C->{$C->{GR}}->{dimension},$C->{$C->{GR}}->{dimension}}/  }))
       
156      |  (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS2} || '(?!)')      |  (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS2} || '(?!)')
157               . ($C->{$C->{ESC_Fe}}->{r_SS2_ESC} ?               . ($C->{$C->{ESC_Fe}}->{r_SS2_ESC} ?
158                   qq/|$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 ($;\%) {
161               ||$C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9               ||$C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9
162               qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'')               qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'')
163          })          })
164        ((??{ $_CHARS_to_RANGE{'b'.$C->{$C->{GL}}->{chars}}        ((??{ $_CHARS_to_RANGE{'b'.$C->{G2}->{chars}}
165              . qq/{$C->{G2}->{dimension},$C->{G2}->{dimension}}/ }))           . qq/{$C->{G2}->{dimension},$C->{G2}->{dimension}}/ }))
166      |  (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS3} || '(?!)')      |  (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS3} || '(?!)')
167               . ($C->{$C->{ESC_Fe}}->{r_SS3_ESC} ?               . ($C->{$C->{ESC_Fe}}->{r_SS3_ESC} ?
168                  qq/|$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 ($;\%) {
171              || $C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9              || $C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9
172               qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'')               qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'')
173          })          })
174        ((??{ $_CHARS_to_RANGE{'b'.$C->{$C->{GL}}->{chars}}        ((??{ $_CHARS_to_RANGE{'b'.$C->{G3}->{chars}}
175              . qq/{$C->{G3}->{dimension},$C->{G3}->{dimension}}/ }))              . qq/{$C->{G3}->{dimension},$C->{G3}->{dimension}}/ }))
176            
177      |((??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' }))  ## GL = G0      ## Locking shift
178      |((??{ $C->{$C->{CL}}->{r_LS1}||'(?!)' }))  ## GL = G1      |(  (??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' })
179           |(??{ $C->{$C->{CL}}->{r_LS1}||'(?!)' })
180         )
181            
182      ## Control sequence      ## Control sequence
183      |(??{ '(?:'.($C->{$C->{CR}}->{r_CSI}||'(?!)')      |(??{ '(?:'.($C->{$C->{CR}}->{r_CSI}||'(?!)')
# Line 314  sub iso2022_to_internal ($;\%) { Line 195  sub iso2022_to_internal ($;\%) {
195      ## Misc. sequence (SP, control, or broken data)      ## Misc. sequence (SP, control, or broken data)
196      |([\x00-\xFF])      |([\x00-\xFF])
197    }{    }{
198      my ($gl,$gr,$ss2,$ss3,$ls0,$ls1,$csi,$esc,$misc)      my ($gl,$gr,$ss2,$ss3,$ls,$csi,$esc,$misc)
199        = ($1,$2,$3,$4,$5,$6,$7,$8,$9,$10);        = ($1,$2,$3,$4,$5,$6,$7,$8,$9);
200      $C->{_irr} = undef unless defined $esc;      $C->{_irr} = undef unless defined $esc;
201      ## GL graphic character      ## GL graphic character
202      if (defined $gl) {      if (defined $gl) {
# Line 325  sub iso2022_to_internal ($;\%) { Line 206  sub iso2022_to_internal ($;\%) {
206          $c = $c * $C->{$C->{GL}}->{chars} + unpack ('C', $_) - $m;          $c = $c * $C->{$C->{GL}}->{chars} + unpack ('C', $_) - $m;
207        }        }
208        chr ($C->{$C->{GL}}->{ucs} + $c);        chr ($C->{$C->{GL}}->{ucs} + $c);
     ## Control, SP, or broken data  
     ## TODO: support control sets other than ISO/IEC 6429's  
     } elsif (defined $misc) {  
       $misc;  
209      ## GR graphic character      ## GR graphic character
210      } elsif ($gr) {      } elsif ($gr) {
211        my $c = 0;        my $c = 0;
# Line 337  sub iso2022_to_internal ($;\%) { Line 214  sub iso2022_to_internal ($;\%) {
214          $c = $c * $C->{$C->{GR}}->{chars} + unpack ('C', $_) - $m;          $c = $c * $C->{$C->{GR}}->{chars} + unpack ('C', $_) - $m;
215        }        }
216        chr ($C->{$C->{GR}}->{ucs} + $c);        chr ($C->{$C->{GR}}->{ucs} + $c);
217        ## Control, SP, or broken data
218        ## TODO: support control sets other than ISO/IEC 6429's
219        } elsif (defined $misc) {
220          $misc;
221      ## Graphic character with SS2      ## Graphic character with SS2
222      } elsif ($ss2) {      } elsif ($ss2) {
223        $ss2 =~ tr/\x80-\xFF/\x00-\x7F/;        $ss2 =~ tr/\x80-\xFF/\x00-\x7F/;
# Line 353  sub iso2022_to_internal ($;\%) { Line 234  sub iso2022_to_internal ($;\%) {
234          $c = $c * $C->{G3}->{chars} + unpack ('C', $_) - $m;          $c = $c * $C->{G3}->{chars} + unpack ('C', $_) - $m;
235        }        }
236        chr ($C->{G3}->{ucs} + $c);        chr ($C->{G3}->{ucs} + $c);
     ## Locking shifts  
       } elsif ($ls0) {  
         $C->{GL} = 'G0'; '';  
       } elsif ($ls1) {  
         $C->{GL} = 'G1'; '';  
237      ## Escape sequence      ## Escape sequence
238      } elsif ($esc) {      } elsif ($esc) {
239        ## IRR (revision number)        if ($esc =~ /\x1B\x26([\x40-\x7E])/) {    ## 6F (IRR) = ESC 02/06 Ft
       if ($esc =~ /\x1B\x26([\x40-\x7E])/) {  
240          $C->{_irr} = $1;  $esc = '';          $C->{_irr} = $1;  $esc = '';
241        } else {        } else {
242          $esc =~ s{          $esc =~ s{
# Line 385  sub iso2022_to_internal ($;\%) { Line 260  sub iso2022_to_internal ($;\%) {
260                $CZD, $C1D, $Fs, $sI, $sF,$ACS)                $CZD, $C1D, $Fs, $sI, $sF,$ACS)
261                = ($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15);                = ($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15);
262            my $rev = $C->{_irr} || '';            my $rev = $C->{_irr} || '';
263            if ($g94_g) {            my $f2s = $C->{option}->{final_to_set};
264              $C->{ $_GB_to_GN{ $g94_g } } = $CHARSET{G94}->{ $g94_f.$rev }            if ($g94_g) { ## ESC 02/08 [I] F
265                                        || $CHARSET{G94}->{ $g94_f }              $C->{ $_GB_to_GN{ $g94_g } }
266                                        || $CHARSET{G94}->{ "\x7E" }; '';                =    $CHARSET{G94}->{ $f2s->{G94}->{$g94_f.$rev} || $g94_f.$rev }
267            } elsif (defined $g94n_f) {                  || $CHARSET{G94}->{ $f2s->{G94}->{$g94_f} || $g94_f }
268              $C->{ $_GB_to_GN{ $g94n_g } || 'G0' } = $CHARSET{G94n}->{ $g94n_f.$rev }                  || $CHARSET{G94}->{ "\x7E" }; '';
269                                        || $CHARSET{G94n}->{ $g94n_f }            } elsif (defined $g94n_f) {   ## ESC 02/04 [02/08..11] [I] F
270                                        || $CHARSET{G94n}->{ "\x7E" }; '';              $C->{ $_GB_to_GN{ $g94n_g } || 'G0' }
271            } elsif ($g96_g) {                =    $CHARSET{G94n}->{ $f2s->{G94n}->{$g94n_f.$rev} || $g94n_f.$rev }
272              $C->{ $_GB_to_GN{ $g96_g } } = $CHARSET{G96}->{ $g96_f.$rev }                  || $CHARSET{G94n}->{ $f2s->{G94n}->{$g94n_f} || $g94n_f }
273                                        || $CHARSET{G96}->{ $g96_f }                  || $CHARSET{G94n}->{ "\x7E" }; '';
274                                        || $CHARSET{G96}->{ "\x7E" }; '';            } elsif ($g96_g) {    ## ESC 02/12..15 [I] F
275            } elsif (defined $g96n_f) {              $C->{ $_GB_to_GN{ $g96_g } }
276              $C->{ $_GB_to_GN{ $g96n_g } } = $CHARSET{G96n}->{ $g96n_f.$rev }                =    $CHARSET{G96}->{ $f2s->{G96}->{$g96_f.$rev} || $g96_f.$rev }
277                                        || $CHARSET{G96n}->{ $g96n_f }                  || $CHARSET{G96}->{ $f2s->{G96}->{$g96_f} || $g96_f }
278                                        || $CHARSET{G96n}->{ "\x7E" }; '';                  || $CHARSET{G96}->{ "\x7E" }; '';
279            } elsif ($Fe) {       ## ESC Fe => C1            } elsif ($g96n_g) {   ## ESC 02/04 02/12..15 [I] F
280                $C->{ $_GB_to_GN{ $g96n_g } }
281                  =    $CHARSET{G96n}->{ $f2s->{G96n}->{$g96n_f.$rev} || $g96n_f.$rev }
282                    || $CHARSET{G96n}->{ $f2s->{G96n}->{$g96n_f} || $g96n_f }
283                    || $CHARSET{G96n}->{ "\x7E" }; '';
284              } elsif ($Fe) {       ## ESC Fe = C1
285              chr ($C->{ $C->{ESC_Fe} }->{ucs} + (ord ($Fe) - 0x40));              chr ($C->{ $C->{ESC_Fe} }->{ucs} + (ord ($Fe) - 0x40));
286            } elsif ($CZD) {            } elsif (defined $Fs) {       ## ESC Fs
             $C->{C0} = $CHARSET{C0}->{ $CZD.$rev }  
                     || $CHARSET{C0}->{ $CZD } || $CHARSET{C0}->{ "\x7E" }; '';  
           } elsif ($C1D) {  
             $C->{C1} = $CHARSET{C1}->{ $C1D.$rev }  
                     || $CHARSET{C1}->{ $C1D } || $CHARSET{C1}->{ "\x7E" }; '';  
           } elsif ($Fs) {  
287              if ($Fs eq "\x6E") {        ## LS2              if ($Fs eq "\x6E") {        ## LS2
288                $C->{GL} = 'G2'; '';                $C->{GL} = 'G2'; '';
289              } elsif ($Fs eq "\x6F") {   ## LS3              } elsif ($Fs eq "\x6F") {   ## LS3
290                $C->{GL} = 'G3'; '';                $C->{GL} = 'G3'; '';
291              } elsif ($Fs eq "\x7E") {   ## LS1R              } elsif ($Fs eq "\x7E" || $Fs eq "\x6B") {  ## LS1R
292                $C->{GR} = 'G1';  $C->{GL} = 'G1' if $C->{bit} == 7; '';                $C->{GR} = 'G1';  $C->{GL} = 'G1' if $C->{bit} == 7; '';
293              } elsif ($Fs eq "\x7D") {   ## LS2R              } elsif ($Fs eq "\x7D" || $Fs eq "\x6C") {  ## LS2R
294                $C->{GR} = 'G2';  $C->{GL} = 'G2' if $C->{bit} == 7; '';                $C->{GR} = 'G2';  $C->{GL} = 'G2' if $C->{bit} == 7; '';
295              } elsif ($Fs eq "\x7C") {   ## LS3R              } elsif ($Fs eq "\x7C" || $Fs eq "\x6D") {  ## LS3R
296                $C->{GR} = 'G3';  $C->{GL} = 'G3' if $C->{bit} == 7; '';                $C->{GR} = 'G3';  $C->{GL} = 'G3' if $C->{bit} == 7; '';
297              } else {              } else {
298                chr ($CHARSET{single_control}->{Fs}->{ucs} + (ord ($Fs) - 0x60));                chr ($CHARSET{single_control}->{Fs}->{ucs} + (ord ($Fs) - 0x60));
299              }              }
300            } elsif ($sI) {            } elsif (defined $CZD) {      ## 1F (CZD) = ESC 02/01 [I] F
301                $C->{C0} = $CHARSET{C0}->{ $f2s->{C0}->{$CZD.$rev} || $CZD.$rev }
302                        || $CHARSET{C0}->{ $f2s->{C0}->{$CZD} || $CZD }
303                        || $CHARSET{C0}->{ "\x7E" }; '';
304              } elsif (defined $C1D) {      ## 2F (C1D) = ESC 02/02 [I] F
305                $C->{C1} = $CHARSET{C1}->{ $f2s->{C1}->{$C1D.$rev} || $C1D.$rev }
306                        || $CHARSET{C1}->{ $f2s->{C1}->{$C1D} || $C1D }
307                        || $CHARSET{C1}->{ "\x7E" }; '';
308              } elsif ($sI) {       ## 3F = ESC 02/03 [I] F
309              chr ($CHARSET{single_control}->{'3F'.$sI}->{ucs} + (ord ($sF) - 0x30));              chr ($CHARSET{single_control}->{'3F'.$sI}->{ucs} + (ord ($sF) - 0x30));
310            } elsif ($ACS) {      ## Announcer            } elsif ($ACS) {      ## 0F (Announcer) = ESC 02/00 F
311              if ($ACS eq "\x4A") { $C->{bit} = 7 }              if ($ACS eq "\x4A") { $C->{bit} = 7 }
312              elsif ($ACS eq "\x4B") { $C->{bit} = 8 }              elsif ($ACS eq "\x4B") { $C->{bit} = 8 }
313              '';              '';
# Line 434  sub iso2022_to_internal ($;\%) { Line 316  sub iso2022_to_internal ($;\%) {
316          $C->{_irr} = undef;          $C->{_irr} = undef;
317        }        }
318        $esc;        $esc;
319      ## Control sequence      } elsif ($ls) {     ## Locking shifts = LS0 / LS1
320      } elsif ($csi) {        if ($ls eq $C->{$C->{CL}}->{LS0}) {
321            $C->{GL} = 'G0'; '';
322          } elsif ($ls eq $C->{$C->{CL}}->{LS1}) {
323            $C->{GL} = 'G1'; '';
324          }
325        } elsif ($csi) {    ## Control sequence = CSI [P..] [I] F
326        $csi =~ tr/\xA0-\xFF/\x20-\x7F/d;        $csi =~ tr/\xA0-\xFF/\x20-\x7F/d;
327        $csi =~ s/$C->{$C->{CL}}->{LS0}//g if $C->{$C->{CL}}->{LS0};        $csi =~ s/$C->{$C->{CL}}->{LS0}//g if $C->{$C->{CL}}->{LS0};
328        $csi =~ s/$C->{$C->{CL}}->{LS1}//g if $C->{$C->{CL}}->{LS1};        $csi =~ s/$C->{$C->{CL}}->{LS1}//g if $C->{$C->{CL}}->{LS1};
329        "\x9B".$csi;        "\x9B".$csi;
330      }      }
331    }gex;    }gesx;
332    $s;    $s;
333  }  } # __iso2022_to_internal
334    
335      };
336      &__iso2022_to_internal (@_) if defined $_[0];
337    
338    } # _iso2022_to_internal
339    
340  sub internal_to_iso2022 ($\%) {  sub internal_to_iso2022 ($;%) {
341    my ($s, $C) = @_;    my ($s, $C) = @_;
342    $C ||= &new_object;    $C ||= &new_object;
343        
344    my $r = '';    my $r = '';
345    for my $c (split //, $s) {    my @c = split //, $s;
346      my $cc = ord $c;    for my $i (0..$#c) {
347        my $c = $c[$i]; my $cc = ord $c;  Encode::_utf8_off ($c);
348      my $t;      my $t;
349      if ($cc <= 0x1F) {      if ($cc <= 0x1F) {
350        $t = _i2c ($c, $C, type => 'C0', charset => '@');        $t = _i2c ($c, $C, type => 'C0', charset => '@');
# Line 460  sub internal_to_iso2022 ($\%) { Line 353  sub internal_to_iso2022 ($\%) {
353      } elsif ($cc < 0x7F) {      } elsif ($cc < 0x7F) {
354        $t = _i2g ($c, $C, type => 'G94', charset => 'B');        $t = _i2g ($c, $C, type => 'G94', charset => 'B');
355      } elsif ($cc <= 0x9F) {      } elsif ($cc <= 0x9F) {
356        $t = _i2c ($c, $C, type => 'C1', charset_id => '64291991C1',        $t = _i2c (pack ('C', $cc), $C, type => 'C1', charset_id => '64291991C1',
357          charset => $C->{private_set}->{XC1}->{'64291991C1'});          charset => $C->{option}->{private_set}->{XC1}->{'64291991C1'});
358      } elsif ($cc <= 0xFF) {      } elsif ($cc <= 0xFF) {
359        $t = _i2g (chr($cc-0x80), $C, type => 'G96', charset => 'A');        $t = _i2g (pack ('C', $cc-0x80), $C, type => 'G96', charset => 'A');
360      } elsif ($cc <= 0x24FF) {      } elsif ($cc <= 0x24FF) {
361        my $c = $cc - 0x100;        my $c = $cc - 0x100;
362        my $final = $C->{private_set}->{U96n}->[0];        my $final = $C->{option}->{private_set}->{U96n}->[0];
363        if (length $final) {        if (length $final) {
364          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
365            type => 'G96n', charset => $final);            type => 'G96n', charset => $final);
366        }        }
367      } elsif ($cc <= 0x33FF) {      } elsif ($cc <= 0x33FF) {
368        my $c = $cc - 0x2500;        my $c = $cc - 0x2500;
369        my $final = $C->{private_set}->{U96n}->[1];        my $final = $C->{option}->{private_set}->{U96n}->[1];
370        if (length $final) {        if (length $final) {
371          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
372            type => 'G96n', charset => $final);            type => 'G96n', charset => $final);
373        }        }
374      } elsif (0xE000 <= $cc && $cc <= 0xFFFF) {      } elsif (0xE000 <= $cc && $cc <= 0xFFFF) {
375        my $c = $cc - 0xE000;        my $c = $cc - 0xE000;
376        my $final = $C->{private_set}->{U96n}->[2];        my $final = $C->{option}->{private_set}->{U96n}->[2];
377        if (length $final) {        if (length $final) {
378          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
379            type => 'G96n', charset => $final);            type => 'G96n', charset => $final);
# Line 546  sub internal_to_iso2022 ($\%) { Line 439  sub internal_to_iso2022 ($\%) {
439      } elsif (0x70400000 <= $cc && $cc <= 0x7040FFED) {      } elsif (0x70400000 <= $cc && $cc <= 0x7040FFED) {
440        my $c = $cc - 0x70400000;        my $c = $cc - 0x70400000;
441        $t = _i2g (chr(($c % 94)+0x21), $C, charset_id => 'P'.int ($c / 94),        $t = _i2g (chr(($c % 94)+0x21), $C, charset_id => 'P'.int ($c / 94),
442            type => 'G94', charset => $C->{private_set}->{G94}->[ $c / 94 ]);            type => 'G94', charset => $C->{option}->{private_set}->{G94}->[ $c / 94 ]);
443      } elsif (0x70410000 <= $cc && $cc <= 0x7041FFBF) {      } elsif (0x70410000 <= $cc && $cc <= 0x7041FFBF) {
444        my $c = $cc - 0x70410000;        my $c = $cc - 0x70410000;
445        $t = _i2g (chr(($c % 96)+0x20), $C, charset_id => 'P'.int ($c / 96),        $t = _i2g (chr(($c % 96)+0x20), $C, charset_id => 'P'.int ($c / 96),
446            type => 'G96', charset => $C->{private_set}->{G96}->[ $c / 96 ]);            type => 'G96', charset => $C->{option}->{private_set}->{G96}->[ $c / 96 ]);
447      } elsif (0x70420000 <= $cc && $cc <= 0x7046F19B) {      } elsif (0x70420000 <= $cc && $cc <= 0x7046F19B) {
448        my $c = $cc % 0x10000;        my $c = $cc % 0x10000;
449        $t = _i2g (chr((($c % 8836) / 94)+0x21).chr(($c % 94)+0x21), $C,        $t = _i2g (chr((($c % 8836) / 94)+0x21).chr(($c % 94)+0x21), $C,
450            type => 'G94n',            type => 'G94n',
451            charset_id => 'P'.int(($cc / 0x10000) - 0x7042).'_'.int($c / 8836),            charset_id => 'P'.int(($cc / 0x10000) - 0x7042).'_'.int($c / 8836),
452            charset => $C->{private_set}->{G94n}->[ ($cc / 0x10000) - 0x7042 ]            charset => $C->{option}->{private_set}->{G94n}
453                         ->[ $c / 8836 ]);                         ->[ ($cc / 0x10000) - 0x7042 ]->[ $c / 8836 ]);
454      }      }
455      if (defined $t) {      if (defined $t) {
456          ## Back to ISO/IEC 2022 if necessary
457          $t = _i2o ($t, $C, cs_F => "\x40")
458            if $C->{coding_system} ne $CODING_SYSTEM{"\x40"};
459        } else {
460          ## Output in UCS-n or UTF-n if character can't be represented in ISO/IEC 2022
461          my $F;  my @F = qw~G /G /H /I  B  /A /D /F~;
462          push @F, qw~/J /K /L~ if $cc <= 0x10FFFF;
463          push @F, qw~/@ /C /E~ if $cc <= 0xFFFF;
464          for (@F) {
465            if (defined $C->{option}->{designate_to}->{coding_system}->{$_}
466                && $C->{option}->{designate_to}->{coding_system}->{$_} > -1) {
467              $F = $_; last;
468            } elsif ($C->{option}->{designate_to}->{coding_system}->{default} > -1) {
469              $F = $_; last;
470            }
471          }
472          $t = _i2o ($c, $C, cs_F => $F) if $F;
473        }
474        if (defined $t) {   ## Output the character itself
475        $r .= $t;        $r .= $t;
476        } elsif ($C->{option}->{fallback_from_ucs} =~ /quiet/) {
477          $r .= _back2ascii ($C) if $C->{option}->{fallback_from_ucs} =~ /back/;
478          return ($r, halfway => 1, converted_length => $i,
479                  warn => $C->{option}->{fallback_from_ucs} =~ /warn/ ? 1 : 0,
480                  reason => sprintf (q(U+%04X: There is no character mapped to), $cc));
481        } elsif ($C->{option}->{fallback_from_ucs} eq 'croak') {
482          return ($r, halfway => 1, die => 1,
483                  reason => sprintf (q(U+%04X: There is no character mapped to), $cc));
484      } else {      } else {
485        $r .= _i2g ("\x3F", $C, type => 'G94', charset => 'B');        ## Try to output with fallback escape sequence (if specified)
486          my $t = Encode::Charset->fallback_escape ($C, $c);
487          if (defined $t) {
488            my %D = (fallback => $C->{option}->{fallback_from_ucs}, reset => $C->{option}->{reset});
489            $C->{option}->{fallback_from_ucs} = 'croak';
490            $C->{option}->{reset} = {Gdesignation => 0, Ginvoke => 0};
491            eval q{$t = $C->{_encoder}->_encode_internal ($t, $C)} or undef $t;
492            $C->{option}->{fallback_from_ucs} = $D{fallback};
493            $C->{option}->{reset} = $D{reset};
494          }
495          if (defined $t) {
496            $r .= $t;
497          } else {  ## Replacement character specified in charset definition
498            unless ($C->{option}->{undef_char}->[0] eq "\x20") {    ## A graphic character
499              $t = _i2g ($C->{option}->{undef_char}->[0], $C,
500                          %{ $C->{option}->{undef_char}->[1] });
501            } else {        ## SPACE
502              $t = _back2ascii ($C) . "\x20";
503            }
504            $r .= $C->{coding_system} eq $CODING_SYSTEM{"\x40"} ?
505                  $t : _i2o ($t, $C, cs_F => "\x40");
506          }
507      }      }
508    }    }
509    $r . _back2ascii ($C);    ($r . _back2ascii ($C));      ## Back to ASCII at the end of document if specified
510  }  }
511    
512  ## $O{charset} eq undef means that charset is same as the current designated one.  ## $O{charset} eq undef means that charset is same as the current designated one.
# Line 608  sub _i2c ($%%) { Line 549  sub _i2c ($%%) {
549      }      }
550      $r .= _back2ascii ($C, reset_all => $C->{C1}->{reset_all}->{$s});      $r .= _back2ascii ($C, reset_all => $C->{C1}->{reset_all}->{$s});
551      unless ($C->{option}->{C1invoke_to_right}) {        ## ESC Fe      unless ($C->{option}->{C1invoke_to_right}) {        ## ESC Fe
552        $s =~ s/([\x80-\x9F])/"\x1B" . chr (ord ($1) - 0x40)/ge;        $s =~ s/([\x80-\x9F])/"\x1B" . pack ('C', ord ($1) - 0x40)/ge;
553      }      }
554      return $r . $s;      return $r . $s;
555    }    }
# Line 616  sub _i2c ($%%) { Line 557  sub _i2c ($%%) {
557  sub _i2g ($%%) {  sub _i2g ($%%) {
558    my ($s, $C, %O) = @_;    my ($s, $C, %O) = @_;
559    my $r = '';    my $r = '';
560    my $set = $CHARSET{$O{type}}->{$O{charset}};    my $set = $CHARSET{$O{type}}->{$O{charset}.
561        ($O{revision}&&$C->{option}->{use_revision}?$O{revision}:'')};
562    my $set0 = $CHARSET{$O{type}}->{$O{charset_id}};    my $set0 = $CHARSET{$O{type}}->{$O{charset_id}};
563    ## -- designate character set    ## -- designate character set
564    my $G = 0;    my $G = 0;
# Line 670  sub _i2g ($%%) { Line 612  sub _i2g ($%%) {
612        } elsif ($C->{C0}->{'C_SS'.$G}) {        } elsif ($C->{C0}->{'C_SS'.$G}) {
613          $r .= _i2c ($C->{C0}->{'C_SS'.$G}, $C, type => 'C0') || return undef;          $r .= _i2c ($C->{C0}->{'C_SS'.$G}, $C, type => 'C0') || return undef;
614        } else {  ## Both C0 and C1 set do not have SS2/3.        } else {  ## Both C0 and C1 set do not have SS2/3.
615            $left = 0 if $G == 1 && !$C->{C0}->{C_LS1};
616          $r .= __invoke ($C, $G => $left) if $C->{$left?'GL':'GR'} ne 'G'.$G;          $r .= __invoke ($C, $G => $left) if $C->{$left?'GL':'GR'} ne 'G'.$G;
617        }        }
618      } else {      } else {
# Line 716  sub __invoke (\%$$) { Line 659  sub __invoke (\%$$) {
659    }    }
660    '';    '';
661  }  }
662    sub _i2o ($\%%) {
663  sub make_charset (%) {    my ($s, $C, %O) = @_;
664  ## TODO: support private charset ID such as 'X0'    my $CS = $CODING_SYSTEM{ $O{cs_F} } || $CODING_SYSTEM{ $O{cs_id} } || return undef;
665    my %set = @_;    my $r = '';
666    my $setid = qq($set{I}$set{F}$set{revision});    if ($CS ne $C->{coding_system}) {
667    my $settype = $set{type} || 'G94';      my $e = '';
668    delete $set{type}, $set{I}, $set{F}, $set{revision};      $e .= "\x1B\x25";
669    $CHARSET{ $settype }->{ $setid } = \%set;      $e .= $O{cs_F} || $C->{option}->{private_set}->{coding_system}->{ $O{cs_id} }
670              || return undef;
671        if ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x40"}
672         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x43"}
673         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x45"}
674         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4A"}
675         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4B"}
676         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4C"}) {
677          $e =~ s/(.)/\x00$1/go;
678        } elsif ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x41"}
679         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x44"}
680         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x46"}) {
681          $e =~ s/(.)/\x00\x00\x00$1/go;
682        }
683        $r .= $e;
684        $C->{coding_system} = $CS;
685        if ($CS->{reset_state}) {
686          $C->{GL} = undef;  $C->{GR} = undef;
687          $C->{C0} = $CHARSET{C0}->{"\x7E"};
688          $C->{C1} = $CHARSET{C1}->{"\x7E"};
689          $C->{G0} = $CHARSET{G94}->{"\x7E"};
690          $C->{G1} = $CHARSET{G94}->{"\x7E"};
691          $C->{G2} = $CHARSET{G94}->{"\x7E"};
692          $C->{G3} = $CHARSET{G94}->{"\x7E"};
693        }
694      }
695      if ($CS eq $CODING_SYSTEM{"\x40"}) {
696        #
697      } elsif ($CS eq $CODING_SYSTEM{G} || $CS eq $CODING_SYSTEM{'/G'}
698            || $CS eq $CODING_SYSTEM{'/H'} || $CS eq $CODING_SYSTEM{'/I'}) {
699        Encode::_utf8_off ($s);
700      } elsif ($CS eq $CODING_SYSTEM{'/@'} || $CS eq $CODING_SYSTEM{'/C'}
701            || $CS eq $CODING_SYSTEM{'/E'}) {
702        $s = Encode::encode ('ucs-2be', $s);
703      } elsif ($CS eq $CODING_SYSTEM{'/A'} || $CS eq $CODING_SYSTEM{'/D'}
704            || $CS eq $CODING_SYSTEM{'/F'}) {
705        $s = Encode::encode ('ucs-4be', $s);
706      } elsif ($CS eq $CODING_SYSTEM{'/J'} || $CS eq $CODING_SYSTEM{'/K'}
707            || $CS eq $CODING_SYSTEM{'/L'}) {
708        $s = Encode::encode ('UTF-16BE', $s);
709      } elsif ($CS eq $CODING_SYSTEM{B}) {
710        $s = Encode::encode ('utf-1', $s);
711      } else {
712        return undef;
713      }
714      $r . $s;
715  }  }
716    
 1;  
 __END__  
   
717  =head1 SEE ALSO  =head1 SEE ALSO
718    
719  ISO/IEC 646:1991, "7-bit coded graphic character set for intormation interchange".  ISO/IEC 646:1991, "7-bit coded graphic character set for intormation interchange".
# Line 744  ISO/IEC 6429:1992, "Control Functions fo Line 729  ISO/IEC 6429:1992, "Control Functions fo
729    
730  ISO/IEC 8859, "8-Bit Single-Byte Coded Graphic Character Sets".  ISO/IEC 8859, "8-Bit Single-Byte Coded Graphic Character Sets".
731    
732  Encode, perlunicode  L<Encode>, perlunicode
733    
734    =head1 TODO
735    
736    =over 4
737    
738    =item NCR (coding system other than ISO/IEC 2022) support
739    
740    =over 2
741    
742    =item ESC 02/05 02/15 03/x of X Compound Text
743    
744    =back
745    
746    =item Output of control character sets, single control functions
747    
748    =item Designation sequence of control character sets (input)
749    
750    =item Special graphic character sets such as G3 of EUC-TW
751    
752    =item SUPER SHIFT (SS) invoke function of old control character set
753    
754    =item Safe transparent of control string (ISO/IEC 6429)
755    
756    =item Output of unoutputable characters as alternative notation such as SGML-like entity
757    
758    =item C0 set invoked to CR area like ISIRI code
759    
760    Really need?
761    
762    =item special treatment of 0x20, 0x7E, 0xA0, 0xFF
763    
764    For example, GB mongolian sets use MSP (MONGOLIAN SPACE)
765    with these code positions.
766    
767    And, no less coding systems does not use (or does ban using) DEL.
768    
769    =item A lot of character sets don't have pseudo-UCS mapping.
770    
771    Most of 9m^n (n >= 3) sets, 9m^n sets with I byte, 9m^n
772    DRCSes do not have pseudo-UCS mapping area.  It is
773    questionable to allocate lots of code positions to these
774    rarely-(or no-)used character sets.
775    
776    =item Even character sets that have pseudo-UCS mapping, some of them can't be outputed in ISO/IEC 2022.
777    
778    Because output of rarely-used character sets is
779    not implemented yet.
780    
781    =back
782    
783    =head1 AUTHORS
784    
785    Nanashi-san  <nanashi.san@nanashi.invalid>
786    
787    Wakaba <w@suika.fam.cx>
788    
789  =head1 LICENSE  =head1 LICENSE
790    
791  Copyright 2002 wakaba <w@suika.fam.cx>  Copyright 2002 AUTHORS, all rights reserved.
792    
793  This library is free software; you can redistribute it  This library is free software; you can redistribute it
794  and/or modify it under the same terms as Perl itself.  and/or modify it under the same terms as Perl itself.
795    
796  =cut  =cut
797    
798  # $Date$  1; # $Date$
 ### ISO2022.pm ends here  
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.14
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24