/[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.10 by wakaba, Wed Oct 16 10:39:35 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  sub internal_to_iso2022 ($\%) {    };
336      &__iso2022_to_internal (@_) if defined $_[0];
337    
338    } # _iso2022_to_internal
339    
340    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) {    for my $c (split //, $s) {
346      my $cc = ord $c;      my $cc = ord $c;  Encode::_utf8_off ($c);
347      my $t;      my $t;
348      if ($cc <= 0x1F) {      if ($cc <= 0x1F) {
349        $t = _i2c ($c, $C, type => 'C0', charset => '@');        $t = _i2c ($c, $C, type => 'C0', charset => '@');
# Line 460  sub internal_to_iso2022 ($\%) { Line 352  sub internal_to_iso2022 ($\%) {
352      } elsif ($cc < 0x7F) {      } elsif ($cc < 0x7F) {
353        $t = _i2g ($c, $C, type => 'G94', charset => 'B');        $t = _i2g ($c, $C, type => 'G94', charset => 'B');
354      } elsif ($cc <= 0x9F) {      } elsif ($cc <= 0x9F) {
355        $t = _i2c ($c, $C, type => 'C1', charset_id => '64291991C1',        $t = _i2c (pack ('C', $cc), $C, type => 'C1', charset_id => '64291991C1',
356          charset => $C->{private_set}->{XC1}->{'64291991C1'});          charset => $C->{option}->{private_set}->{XC1}->{'64291991C1'});
357      } elsif ($cc <= 0xFF) {      } elsif ($cc <= 0xFF) {
358        $t = _i2g (chr($cc-0x80), $C, type => 'G96', charset => 'A');        $t = _i2g (pack ('C', $cc-0x80), $C, type => 'G96', charset => 'A');
359      } elsif ($cc <= 0x24FF) {      } elsif ($cc <= 0x24FF) {
360        my $c = $cc - 0x100;        my $c = $cc - 0x100;
361        my $final = $C->{private_set}->{U96n}->[0];        my $final = $C->{option}->{private_set}->{U96n}->[0];
362        if (length $final) {        if (length $final) {
363          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
364            type => 'G96n', charset => $final);            type => 'G96n', charset => $final);
365        }        }
366      } elsif ($cc <= 0x33FF) {      } elsif ($cc <= 0x33FF) {
367        my $c = $cc - 0x2500;        my $c = $cc - 0x2500;
368        my $final = $C->{private_set}->{U96n}->[1];        my $final = $C->{option}->{private_set}->{U96n}->[1];
369        if (length $final) {        if (length $final) {
370          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
371            type => 'G96n', charset => $final);            type => 'G96n', charset => $final);
372        }        }
373      } elsif (0xE000 <= $cc && $cc <= 0xFFFF) {      } elsif (0xE000 <= $cc && $cc <= 0xFFFF) {
374        my $c = $cc - 0xE000;        my $c = $cc - 0xE000;
375        my $final = $C->{private_set}->{U96n}->[2];        my $final = $C->{option}->{private_set}->{U96n}->[2];
376        if (length $final) {        if (length $final) {
377          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
378            type => 'G96n', charset => $final);            type => 'G96n', charset => $final);
# Line 546  sub internal_to_iso2022 ($\%) { Line 438  sub internal_to_iso2022 ($\%) {
438      } elsif (0x70400000 <= $cc && $cc <= 0x7040FFED) {      } elsif (0x70400000 <= $cc && $cc <= 0x7040FFED) {
439        my $c = $cc - 0x70400000;        my $c = $cc - 0x70400000;
440        $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),
441            type => 'G94', charset => $C->{private_set}->{G94}->[ $c / 94 ]);            type => 'G94', charset => $C->{option}->{private_set}->{G94}->[ $c / 94 ]);
442      } elsif (0x70410000 <= $cc && $cc <= 0x7041FFBF) {      } elsif (0x70410000 <= $cc && $cc <= 0x7041FFBF) {
443        my $c = $cc - 0x70410000;        my $c = $cc - 0x70410000;
444        $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),
445            type => 'G96', charset => $C->{private_set}->{G96}->[ $c / 96 ]);            type => 'G96', charset => $C->{option}->{private_set}->{G96}->[ $c / 96 ]);
446      } elsif (0x70420000 <= $cc && $cc <= 0x7046F19B) {      } elsif (0x70420000 <= $cc && $cc <= 0x7046F19B) {
447        my $c = $cc % 0x10000;        my $c = $cc % 0x10000;
448        $t = _i2g (chr((($c % 8836) / 94)+0x21).chr(($c % 94)+0x21), $C,        $t = _i2g (chr((($c % 8836) / 94)+0x21).chr(($c % 94)+0x21), $C,
449            type => 'G94n',            type => 'G94n',
450            charset_id => 'P'.int(($cc / 0x10000) - 0x7042).'_'.int($c / 8836),            charset_id => 'P'.int(($cc / 0x10000) - 0x7042).'_'.int($c / 8836),
451            charset => $C->{private_set}->{G94n}->[ ($cc / 0x10000) - 0x7042 ]            charset => $C->{option}->{private_set}->{G94n}
452                         ->[ $c / 8836 ]);                         ->[ ($cc / 0x10000) - 0x7042 ]->[ $c / 8836 ]);
453        }
454        if (defined $t) {
455          $t = _i2o ($t, $C, cs_F => "\x40")
456            if $C->{coding_system} ne $CODING_SYSTEM{"\x40"};
457        } else {
458          my $F;  my @F = qw~G /G /H /I  B  /A /D /F~;
459          push @F, qw~/J /K /L~ if $cc <= 0x10FFFF;
460          push @F, qw~/@ /C /E~ if $cc <= 0xFFFF;
461          for (@F) {
462            if (defined $C->{option}->{designate_to}->{coding_system}->{$_}
463                && $C->{option}->{designate_to}->{coding_system}->{$_} > -1) {
464              $F = $_; last;
465            } elsif ($C->{option}->{designate_to}->{coding_system}->{default} > -1) {
466              $F = $_; last;
467            }
468          }
469          $t = _i2o ($c, $C, cs_F => $F) if $F;
470      }      }
471      if (defined $t) {      if (defined $t) {
472        $r .= $t;        $r .= $t;
473      } else {      } else {
474        $r .= _i2g ("\x3F", $C, type => 'G94', charset => 'B');        unless ($C->{option}->{undef_char}->[0] eq "\x20") {
475            $t = _i2g ($C->{option}->{undef_char}->[0], $C,
476                        %{ $C->{option}->{undef_char}->[1] });
477          } else {  ## SP
478            $t = _back2ascii ($C) . "\x20";
479          }
480          $r .= $C->{coding_system} eq $CODING_SYSTEM{"\x40"} ?
481                $t : _i2o ($t, $C, cs_F => "\x40");
482      }      }
483    }    }
484    $r . _back2ascii ($C);    $r . _back2ascii ($C);
# Line 608  sub _i2c ($%%) { Line 524  sub _i2c ($%%) {
524      }      }
525      $r .= _back2ascii ($C, reset_all => $C->{C1}->{reset_all}->{$s});      $r .= _back2ascii ($C, reset_all => $C->{C1}->{reset_all}->{$s});
526      unless ($C->{option}->{C1invoke_to_right}) {        ## ESC Fe      unless ($C->{option}->{C1invoke_to_right}) {        ## ESC Fe
527        $s =~ s/([\x80-\x9F])/"\x1B" . chr (ord ($1) - 0x40)/ge;        $s =~ s/([\x80-\x9F])/"\x1B" . pack ('C', ord ($1) - 0x40)/ge;
528      }      }
529      return $r . $s;      return $r . $s;
530    }    }
# Line 616  sub _i2c ($%%) { Line 532  sub _i2c ($%%) {
532  sub _i2g ($%%) {  sub _i2g ($%%) {
533    my ($s, $C, %O) = @_;    my ($s, $C, %O) = @_;
534    my $r = '';    my $r = '';
535    my $set = $CHARSET{$O{type}}->{$O{charset}};    my $set = $CHARSET{$O{type}}->{$O{charset}.
536        ($O{revision}&&$C->{option}->{use_revision}?$O{revision}:'')};
537    my $set0 = $CHARSET{$O{type}}->{$O{charset_id}};    my $set0 = $CHARSET{$O{type}}->{$O{charset_id}};
538    ## -- designate character set    ## -- designate character set
539    my $G = 0;    my $G = 0;
# Line 670  sub _i2g ($%%) { Line 587  sub _i2g ($%%) {
587        } elsif ($C->{C0}->{'C_SS'.$G}) {        } elsif ($C->{C0}->{'C_SS'.$G}) {
588          $r .= _i2c ($C->{C0}->{'C_SS'.$G}, $C, type => 'C0') || return undef;          $r .= _i2c ($C->{C0}->{'C_SS'.$G}, $C, type => 'C0') || return undef;
589        } else {  ## Both C0 and C1 set do not have SS2/3.        } else {  ## Both C0 and C1 set do not have SS2/3.
590            $left = 0 if $G == 1 && !$C->{C0}->{C_LS1};
591          $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;
592        }        }
593      } else {      } else {
# Line 716  sub __invoke (\%$$) { Line 634  sub __invoke (\%$$) {
634    }    }
635    '';    '';
636  }  }
637    sub _i2o ($\%%) {
638  sub make_charset (%) {    my ($s, $C, %O) = @_;
639  ## TODO: support private charset ID such as 'X0'    my $CS = $CODING_SYSTEM{ $O{cs_F} } || $CODING_SYSTEM{ $O{cs_id} } || return undef;
640    my %set = @_;    my $r = '';
641    my $setid = qq($set{I}$set{F}$set{revision});    if ($CS ne $C->{coding_system}) {
642    my $settype = $set{type} || 'G94';      my $e = '';
643    delete $set{type}, $set{I}, $set{F}, $set{revision};      $e .= "\x1B\x25";
644    $CHARSET{ $settype }->{ $setid } = \%set;      $e .= $O{cs_F} || $C->{option}->{private_set}->{coding_system}->{ $O{cs_id} }
645              || return undef;
646        if ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x40"}
647         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x43"}
648         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x45"}
649         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4A"}
650         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4B"}
651         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4C"}) {
652          $e =~ s/(.)/\x00$1/go;
653        } elsif ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x41"}
654         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x44"}
655         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x46"}) {
656          $e =~ s/(.)/\x00\x00\x00$1/go;
657        }
658        $r .= $e;
659        $C->{coding_system} = $CS;
660        if ($CS->{reset_state}) {
661          $C->{GL} = undef;  $C->{GR} = undef;
662          $C->{C0} = $CHARSET{C0}->{"\x7E"};
663          $C->{C1} = $CHARSET{C1}->{"\x7E"};
664          $C->{G0} = $CHARSET{G94}->{"\x7E"};
665          $C->{G1} = $CHARSET{G94}->{"\x7E"};
666          $C->{G2} = $CHARSET{G94}->{"\x7E"};
667          $C->{G3} = $CHARSET{G94}->{"\x7E"};
668        }
669      }
670      if ($CS eq $CODING_SYSTEM{"\x40"}) {
671        #
672      } elsif ($CS eq $CODING_SYSTEM{G} || $CS eq $CODING_SYSTEM{'/G'}
673            || $CS eq $CODING_SYSTEM{'/H'} || $CS eq $CODING_SYSTEM{'/I'}) {
674        Encode::_utf8_off ($s);
675      } elsif ($CS eq $CODING_SYSTEM{'/@'} || $CS eq $CODING_SYSTEM{'/C'}
676            || $CS eq $CODING_SYSTEM{'/E'}) {
677        $s = Encode::encode ('ucs-2be', $s);
678      } elsif ($CS eq $CODING_SYSTEM{'/A'} || $CS eq $CODING_SYSTEM{'/D'}
679            || $CS eq $CODING_SYSTEM{'/F'}) {
680        $s = Encode::encode ('ucs-4be', $s);
681      } elsif ($CS eq $CODING_SYSTEM{'/J'} || $CS eq $CODING_SYSTEM{'/K'}
682            || $CS eq $CODING_SYSTEM{'/L'}) {
683        $s = Encode::encode ('UTF-16BE', $s);
684      } elsif ($CS eq $CODING_SYSTEM{B}) {
685        $s = Encode::encode ('utf-1', $s);
686      } else {
687        return undef;
688      }
689      $r . $s;
690  }  }
691    
692  1;  1;
# Line 746  ISO/IEC 8859, "8-Bit Single-Byte Coded G Line 709  ISO/IEC 8859, "8-Bit Single-Byte Coded G
709    
710  Encode, perlunicode  Encode, perlunicode
711    
712    =head1 TODO
713    
714    =over 4
715    
716    =item NCR (coding system other than ISO/IEC 2022) support
717    
718    =over 2
719    
720    =item ESC 02/05 02/15 03/x of X Compound Text
721    
722    =back
723    
724    =item Output of control character sets, single control functions
725    
726    =item Designation sequence of control character sets (input)
727    
728    =item Special graphic character sets such as G3 of EUC-TW
729    
730    =item SUPER SHIFT (SS) invoke function of old control character set
731    
732    =item Safe transparent of control string (ISO/IEC 6429)
733    
734    =item Output of unoutputable characters as alternative notation such as SGML-like entity
735    
736    =item C0 set invoked to CR area like ISIRI code
737    
738    Really need?
739    
740    =item special treatment of 0x20, 0x7E, 0xA0, 0xFF
741    
742    For example, GB mongolian sets use MSP (MONGOLIAN SPACE)
743    with these code positions.
744    
745    And, no less coding systems does not use (or does ban using) DEL.
746    
747    =item A lot of character sets don't have pseudo-UCS mapping.
748    
749    Most of 9m^n (n >= 3) sets, 9m^n sets with I byte, 9m^n
750    DRCSes do not have pseudo-UCS mapping area.  It is
751    questionable to allocate lots of code positions to these
752    rarely-(or no-)used character sets.
753    
754    =item Even character sets that have pseudo-UCS mapping, some of them can't be outputed in ISO/IEC 2022.
755    
756    Because output of rarely-used character sets is
757    not implemented yet.
758    
759    =back
760    
761    =head1 AUTHORS
762    
763    Nanashi-san
764    
765    Wakaba <w@suika.fam.cx>
766    
767  =head1 LICENSE  =head1 LICENSE
768    
769  Copyright 2002 wakaba <w@suika.fam.cx>  Copyright 2002 AUTHORS
770    
771  This library is free software; you can redistribute it  This library is free software; you can redistribute it
772  and/or modify it under the same terms as Perl itself.  and/or modify it under the same terms as Perl itself.
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.10
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24