/[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.3 by wakaba, Mon Sep 16 02:20:18 2002 UTC revision 1.6 by wakaba, Sat Sep 21 01:34:08 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            *CHARSET = \%Encode::Charset::CHARSET;
49            *CODING_SYSTEM = \%Encode::Charset::CODING_SYSTEM;
50    
51  ### --- Intialization  ### --- Intialization
52    
# Line 30  my %_CHARS_to_RANGE = ( Line 65  my %_CHARS_to_RANGE = (
65          b256    => q/[\x00-\xFF]/,          b256    => q/[\x00-\xFF]/,
66  );  );
67    
 ## --- 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};  
 }  
   
   
68  ### --- Perl Encode module common functions  ### --- Perl Encode module common functions
69    
70  sub encode ($$;$) {  sub encode ($$;$) {
# Line 198  sub decode ($$;$) { Line 81  sub decode ($$;$) {
81  }  }
82    
83  ### --- Encode::ISO2022 unique functions  ### --- Encode::ISO2022 unique functions
84    *new_object = \&Encode::Charset::new_object;
85    
86  ## Make a new ISO/IEC 2022-buffers object with default status  sub iso2022_to_internal ($;\%) {
87  sub new_object {    my ($s, $C) = @_;
88    my %C;    $C ||= &new_object;
89    $C{bit} = 8;    my $t = '';
90    $C{CL} = 'C0'; $C{CR} = 'C1'; $C{ESC_Fe} = 'C1';    $s =~ s{
91    $C{C0} = $CHARSET{C0}->{"\x40"};      ## ISO/IEC 6429:1991 C0      ^((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
92    $C{C1} = $CHARSET{C1}->{'64291991C1'};        ## ISO/IEC 6429:1991 C1    }{
93    $C{GL} = 'G0'; $C{GR} = 'G1';      my $i2 = $1;
94    $C{G0} = $CHARSET{G94}->{"\x42"};     ## ISO/IEC 646:1991 IRV      $t = _iso2022_to_internal ($i2, $C);
95    #$C{G1} = $CHARSET{G96}->{"\x41"};    ## ISO/IEC 8859-1 GR      '';
96    $C{G1} = $CHARSET{G94}->{"\x7E"};     ## empty set    }gesx;
97    $C{G2} = $CHARSET{G94}->{"\x7E"};     ## empty set    my $pad = '';
98    $C{G3} = $CHARSET{G94}->{"\x7E"};     ## empty set    use re 'eval';
99    $C{option} = {    $s =~ s{
100          C1invoke_to_right       => 0,   ## C1 invoked to: (0: ESC Fe, 1: CR)       ## ISO/IEC 2022
101          G94n_designate_long     => 0,   ## (1: ESC 02/04 02/08 04/00..02)        (??{"$pad\x1B$pad\x25$pad\x40"})((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
102          designate_to    => {    ## Designated G buffer (-1: not be outputed)       ## UTF-8
103                  C0      => {       |(??{"$pad\x1B$pad\x25$pad(?:\x47|\x2F$pad"."[\x47-\x49])"})
104                          default => 0,         ((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
105                  },       ## UCS-2, UTF-16
106                  C1      => {       |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})([\x40\x43\x45\x4A-\x4C])
107                          default => 1,         ((?:(?!\x00\x1B\x00\x25(?:\x00\x2F)?\x00[\x30-\x7E])..)*)
108                  },       ## UCS-4
109                  G94     => {       |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})[\x41\x44\x46]
110                          "\x42"  => 0,         ((?:(?!\x00\x00\x00\x1B\x00\x00\x00\x25(?:\x00\x00\x00\x2F)?
111                          default => 0,             \x00\x00\x00[\x30-\x7E])....)*)
112                  },       ## with standard return
113                  G96     => {       |(??{"$pad\x1B$pad\x25$pad"})([\x30-\x7E])
114                          default => 1,         ((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
115                  },       ## without standard return
116                  G94n    => {       |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})([\x30-\x7E])(.*)
117                          default => 0,    }{
118                  },      my ($i2,$u8,$Fu2,$u2,$u4,$Fsr,$sr,$Fnsr,$nsr) = ($1,$2,$3,$4,$5,$6,$7,$8,$9);
119                  G96n    => {      my $r = '';
120                          default => 1,      if (defined $i2) {
121                  },        $r = _iso2022_to_internal ($i2, $C);  $pad = '';
122          },      } elsif (defined $u8) {
123          Ginvoke_by_single_shift => [0,0,0,0],   ## Invoked by SS        $r = Encode::decode ('utf8', $u8);  $pad = '';
124          Ginvoke_to_left => [1,1,1,1],   ## Which invoked to? (1: L, 0: R)      } elsif ($Fu2) {
125          private_set     => {    ## Private set vs Final byte        if (ord ($Fu2) > 0x49) {
126                  C0      => [],          $r = Encode::decode ('utf-16be', $u2);
127                  C1      => [],        } else {
128                  G94     => [],          $r = Encode::decode ('ucs-2be', $u2);
129                  G94n    => [[],[],[],[],[]],        }
130                  G96     => [],        $pad = "\x00";
131                  #G96n   => [],  ## (not implemented)      } elsif (defined $u4) {
132                  U96n    => [],  ## mule-unicode sets        $r = Encode::decode ('ucs-4be', $u2);  $pad = "\x00\x00\x00";
133                  XC1     => {      } elsif (defined $Fsr && $CODING_SYSTEM{$Fsr}->{perl_name}) {
134                          '64291991C1'    => undef,       ## ISO/IEC 6429:1991 C1        $r = Encode::decode ($CODING_SYSTEM{$Fsr}->{perl_name}, $sr);  $pad = '';
135                  },      } elsif (defined $Fnsr && $CODING_SYSTEM{$Fnsr}->{perl_name}) {
136          },        $r = Encode::decode ($CODING_SYSTEM{$Fnsr}->{perl_name}, $nsr);  $pad = '';
137          reset => {      ## Reset status at top of line      } else {    ## temporary
138                  Gdesignation    => "\x42",      ## F of designation or 0        $r = '?' x length ($sr.$nsr);  $pad = '';
139                  Ginvoke => 1,      }
140          },      $r;
141          use_revision    => 1,   ## Output IRR    }gesx;
142    };    $t . $s;
   \%C;  
143  }  }
144    
145  sub iso2022_to_internal ($;\%) {  sub _iso2022_to_internal ($;\%) {
146    my ($s, $C) = @_;    my ($s, $C) = @_;
147    my %_GB_to_GN = (    my %_GB_to_GN = (
148      "\x28"=>'G0',"\x29"=>'G1',"\x2A"=>'G2',"\x2B"=>'G3',      "\x28"=>'G0',"\x29"=>'G1',"\x2A"=>'G2',"\x2B"=>'G3',
149      "\x2C"=>'G0',"\x2D"=>'G1',"\x2E"=>'G2',"\x2F"=>'G3',      "\x2C"=>'G0',"\x2D"=>'G1',"\x2E"=>'G2',"\x2F"=>'G3',
150    );    );
   $C ||= &new_object;  
151        
152    use re 'eval';    use re 'eval';
153    $s =~ s{    $s =~ s{
154       ((??{ $_CHARS_to_RANGE{'l'.$C->{$C->{GL}}->{chars}}       ((??{ $_CHARS_to_RANGE{'l'.$C->{$C->{GL}}->{chars}}
155           . qq/{$C->{$C->{GL}}->{dimension},$C->{$C->{GL}}->{dimension}}/ }))           . qq/{$C->{$C->{GL}}->{dimension},$C->{$C->{GL}}->{dimension}}/ }))
156      |((??{ $_CHARS_to_RANGE{'r'.$C->{$C->{GL}}->{chars}}      |((??{ $_CHARS_to_RANGE{'r'.$C->{$C->{GR}}->{chars}}
157           . qq/{$C->{$C->{GR}}->{dimension},$C->{$C->{GR}}->{dimension}}/ }))           . qq/{$C->{$C->{GR}}->{dimension},$C->{$C->{GR}}->{dimension}}/ }))
       
158      |  (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS2} || '(?!)')      |  (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS2} || '(?!)')
159               . ($C->{$C->{ESC_Fe}}->{r_SS2_ESC} ?               . ($C->{$C->{ESC_Fe}}->{r_SS2_ESC} ?
160                   qq/|$C->{$C->{ESC_Fe}}->{r_SS2_ESC}/ : '')                   qq/|$C->{$C->{ESC_Fe}}->{r_SS2_ESC}/ : '')
# Line 282  sub iso2022_to_internal ($;\%) { Line 163  sub iso2022_to_internal ($;\%) {
163               ||$C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9               ||$C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9
164               qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'')               qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'')
165          })          })
166        ((??{ $_CHARS_to_RANGE{'b'.$C->{$C->{GL}}->{chars}}        ((??{ $_CHARS_to_RANGE{'b'.$C->{G2}->{chars}}
167              . qq/{$C->{G2}->{dimension},$C->{G2}->{dimension}}/ }))              . qq/{$C->{G2}->{dimension},$C->{G2}->{dimension}}/ }))
168      |  (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS3} || '(?!)')      |  (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS3} || '(?!)')
169               . ($C->{$C->{ESC_Fe}}->{r_SS3_ESC} ?               . ($C->{$C->{ESC_Fe}}->{r_SS3_ESC} ?
# Line 292  sub iso2022_to_internal ($;\%) { Line 173  sub iso2022_to_internal ($;\%) {
173              || $C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9              || $C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9
174               qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'')               qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'')
175          })          })
176        ((??{ $_CHARS_to_RANGE{'b'.$C->{$C->{GL}}->{chars}}        ((??{ $_CHARS_to_RANGE{'b'.$C->{G3}->{chars}}
177              . qq/{$C->{G3}->{dimension},$C->{G3}->{dimension}}/ }))              . qq/{$C->{G3}->{dimension},$C->{G3}->{dimension}}/ }))
178            
179      ## Locking shift      ## Locking shift
180      |( \x1B[\x6E\x6F\x7C-\x7E]      |(  (??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' })
        |(??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' })  
181         |(??{ $C->{$C->{CL}}->{r_LS1}||'(?!)' })         |(??{ $C->{$C->{CL}}->{r_LS1}||'(?!)' })
182       )       )
183            
# Line 438  sub iso2022_to_internal ($;\%) { Line 318  sub iso2022_to_internal ($;\%) {
318          $C->{GL} = 'G0'; '';          $C->{GL} = 'G0'; '';
319        } elsif ($ls eq $C->{$C->{CL}}->{LS1}) {        } elsif ($ls eq $C->{$C->{CL}}->{LS1}) {
320          $C->{GL} = 'G1'; '';          $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}; '';  
321        }        }
322      ## Control sequence      ## Control sequence
323      } elsif ($csi) {      } elsif ($csi) {
# Line 569  sub internal_to_iso2022 ($\%) { Line 445  sub internal_to_iso2022 ($\%) {
445                         ->[ $c / 8836 ]);                         ->[ $c / 8836 ]);
446      }      }
447      if (defined $t) {      if (defined $t) {
448          $t = _i2o ($t, $C, cs_F => "\x40")
449            if $C->{coding_system} ne $CODING_SYSTEM{"\x40"};
450        } else {
451          my $F;  my @F = qw~G /G /H /I  B  /A /D /F~;
452          push @F, qw~/J /K /L~ if $cc <= 0x10FFFF;
453          push @F, qw~/@ /C /E~ if $cc <= 0xFFFF;
454          for (@F) {
455            if (defined $C->{option}->{designate_to}->{coding_system}->{$_}
456                && $C->{option}->{designate_to}->{coding_system}->{$_} > -1) {
457              $F = $_; last;
458            } elsif ($C->{option}->{designate_to}->{coding_system}->{default} > -1) {
459              $F = $_; last;
460            }
461          }
462          $t = _i2o ($c, $C, cs_F => $F) if $F;
463        }
464        if (defined $t) {
465        $r .= $t;        $r .= $t;
466      } else {      } else {
467        $r .= _i2g ("\x3F", $C, type => 'G94', charset => 'B');        $t = _i2g ($C->{option}->{undef_char}->[0], $C,
468                      %{ $C->{option}->{undef_char}->[1] });
469          $r .= $C->{coding_system} eq $CODING_SYSTEM{"\x40"} ?
470                $t : _i2o ($t, $C, cs_F => "\x40");
471      }      }
472    }    }
473    $r . _back2ascii ($C);    $r . _back2ascii ($C);
# Line 625  sub _i2c ($%%) { Line 521  sub _i2c ($%%) {
521  sub _i2g ($%%) {  sub _i2g ($%%) {
522    my ($s, $C, %O) = @_;    my ($s, $C, %O) = @_;
523    my $r = '';    my $r = '';
524    my $set = $CHARSET{$O{type}}->{$O{charset}};    my $set = $CHARSET{$O{type}}->{$O{charset}.
525        ($O{revision}&&$C->{option}->{use_revision}?$O{revision}:'')};
526    my $set0 = $CHARSET{$O{type}}->{$O{charset_id}};    my $set0 = $CHARSET{$O{type}}->{$O{charset_id}};
527    ## -- designate character set    ## -- designate character set
528    my $G = 0;    my $G = 0;
# Line 679  sub _i2g ($%%) { Line 576  sub _i2g ($%%) {
576        } elsif ($C->{C0}->{'C_SS'.$G}) {        } elsif ($C->{C0}->{'C_SS'.$G}) {
577          $r .= _i2c ($C->{C0}->{'C_SS'.$G}, $C, type => 'C0') || return undef;          $r .= _i2c ($C->{C0}->{'C_SS'.$G}, $C, type => 'C0') || return undef;
578        } else {  ## Both C0 and C1 set do not have SS2/3.        } else {  ## Both C0 and C1 set do not have SS2/3.
579            $left = 0 if $G == 1 && !$C->{C0}->{C_LS1};
580          $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;
581        }        }
582      } else {      } else {
# Line 725  sub __invoke (\%$$) { Line 623  sub __invoke (\%$$) {
623    }    }
624    '';    '';
625  }  }
626    sub _i2o ($\%%) {
627  sub make_charset (%) {    my ($s, $C, %O) = @_;
628  ## TODO: support private charset ID such as 'X0'    my $CS = $CODING_SYSTEM{ $O{cs_F} } || $CODING_SYSTEM{ $O{cs_id} } || return undef;
629    my %set = @_;    my $r = '';
630    my $setid = qq($set{I}$set{F}$set{revision});    if ($CS ne $C->{coding_system}) {
631    my $settype = $set{type} || 'G94';      my $e = '';
632    delete $set{type}, $set{I}, $set{F}, $set{revision};      $e .= "\x1B\x25";
633    $CHARSET{ $settype }->{ $setid } = \%set;      $e .= $O{cs_F} || $C->{private_set}->{coding_system}->{ $O{cs_id} }
634              || return undef;
635        if ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x40"}
636         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x43"}
637         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x45"}
638         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4A"}
639         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4B"}
640         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4C"}) {
641          $e =~ s/(.)/\x00$1/go;
642        } elsif ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x41"}
643         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x44"}
644         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x46"}) {
645          $e =~ s/(.)/\x00\x00\x00$1/go;
646        }
647        $r .= $e;
648        $C->{coding_system} = $CS;
649        if ($CS->{reset_state}) {
650          $C->{GL} = undef;  $C->{GR} = undef;
651          $C->{C0} = $CHARSET{C0}->{"\x7E"};
652          $C->{C1} = $CHARSET{C1}->{"\x7E"};
653          $C->{G0} = $CHARSET{G94}->{"\x7E"};
654          $C->{G1} = $CHARSET{G94}->{"\x7E"};
655          $C->{G2} = $CHARSET{G94}->{"\x7E"};
656          $C->{G3} = $CHARSET{G94}->{"\x7E"};
657        }
658      }
659      if ($CS eq $CODING_SYSTEM{"\x40"}) {
660        #
661      } elsif ($CS eq $CODING_SYSTEM{G} || $CS eq $CODING_SYSTEM{'/G'}
662            || $CS eq $CODING_SYSTEM{'/H'} || $CS eq $CODING_SYSTEM{'/I'}) {
663        Encode::_utf8_off ($s);
664      } elsif ($CS eq $CODING_SYSTEM{'/@'} || $CS eq $CODING_SYSTEM{'/C'}
665            || $CS eq $CODING_SYSTEM{'/E'}) {
666        $s = Encode::encode ('ucs-2be', $s);
667      } elsif ($CS eq $CODING_SYSTEM{'/A'} || $CS eq $CODING_SYSTEM{'/D'}
668            || $CS eq $CODING_SYSTEM{'/F'}) {
669        $s = Encode::encode ('ucs-4be', $s);
670      } elsif ($CS eq $CODING_SYSTEM{'/J'} || $CS eq $CODING_SYSTEM{'/K'}
671            || $CS eq $CODING_SYSTEM{'/L'}) {
672        $s = Encode::encode ('UTF-16BE', $s);
673      } elsif ($CS eq $CODING_SYSTEM{B}) {
674        $s = Encode::encode ('utf-1', $s);
675      } else {
676        return undef;
677      }
678      $r . $s;
679  }  }
680    
681  1;  1;
# Line 755  ISO/IEC 8859, "8-Bit Single-Byte Coded G Line 698  ISO/IEC 8859, "8-Bit Single-Byte Coded G
698    
699  Encode, perlunicode  Encode, perlunicode
700    
701    =head1 TODO
702    
703    =over 4
704    
705    =item NCR (coding system other than ISO/IEC 2022) support
706    
707    =over 2
708    
709    =item ESC 02/05 02/15 03/x of X Compound Text
710    
711    =back
712    
713    =item Output of control character sets, single control functions
714    
715    =item Designation sequence of control character sets (input)
716    
717    =item Special graphic character sets such as G3 of EUC-TW
718    
719    =item SUPER SHIFT (SS) invoke function of old control character set
720    
721    =item Safe transparent of control string (ISO/IEC 6429)
722    
723    =item Output of unoutputable characters as alternative notation such as SGML-like entity
724    
725    =item C0 set invoked to CR area like ISIRI code
726    
727    Really need?
728    
729    =item special treatment of 0x20, 0x7E, 0xA0, 0xFF
730    
731    For example, GB mongolian sets use MSP (MONGOLIAN SPACE)
732    with these code positions.
733    
734    And, no less coding systems does not use (or does ban using) DEL.
735    
736    =item A lot of character sets don't have pseudo-UCS mapping.
737    
738    Most of 9m^n (n >= 3) sets, 9m^n sets with I byte, 9m^n
739    DRCSes do not have pseudo-UCS mapping area.  It is
740    questionable to allocate lots of code positions to these
741    rarely-(or no-)used character sets.
742    
743    =item Even character sets that have pseudo-UCS mapping, some of them can't be outputed in ISO/IEC 2022.
744    
745    Because output of rarely-used character sets is
746    not implemented yet.
747    
748    =back
749    
750    =head1 AUTHORS
751    
752    Nanashi-san
753    
754    Wakaba <w@suika.fam.cx>
755    
756  =head1 LICENSE  =head1 LICENSE
757    
758  Copyright 2002 wakaba <w@suika.fam.cx>  Copyright 2002 AUTHORS
759    
760  This library is free software; you can redistribute it  This library is free software; you can redistribute it
761  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.3  
changed lines
  Added in v.1.6
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24