/[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.5 by wakaba, Fri Sep 20 14:01:45 2002 UTC
# Line 8  Encode::ISO2022 --- ISO/IEC 2022 encoder Line 8  Encode::ISO2022 --- ISO/IEC 2022 encoder
8  require v5.7.3;  require v5.7.3;
9  package Encode::ISO2022;  package Encode::ISO2022;
10  use strict;  use strict;
11  use vars qw(%CHARSET $VERSION);  use vars qw(%CHARSET %CODING_SYSTEM $VERSION);
12  $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};
13  use base qw(Encode::Encoding);  use base qw(Encode::Encoding);
14  __PACKAGE__->Define (qw/iso-2022 iso2022 2022 cp2022/);  __PACKAGE__->Define (qw/iso-2022 iso2022 2022 cp2022/);
15    require Encode::Charset;
16            *CHARSET = \%Encode::Charset::CHARSET;
17            *CODING_SYSTEM = \%Encode::Charset::CODING_SYSTEM;
18    
19  ### --- Intialization  ### --- Intialization
20    
# Line 30  my %_CHARS_to_RANGE = ( Line 33  my %_CHARS_to_RANGE = (
33          b256    => q/[\x00-\xFF]/,          b256    => q/[\x00-\xFF]/,
34  );  );
35    
 ## --- 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};  
 }  
   
   
36  ### --- Perl Encode module common functions  ### --- Perl Encode module common functions
37    
38  sub encode ($$;$) {  sub encode ($$;$) {
# Line 212  sub new_object { Line 63  sub new_object {
63    $C{G1} = $CHARSET{G94}->{"\x7E"};     ## empty set    $C{G1} = $CHARSET{G94}->{"\x7E"};     ## empty set
64    $C{G2} = $CHARSET{G94}->{"\x7E"};     ## empty set    $C{G2} = $CHARSET{G94}->{"\x7E"};     ## empty set
65    $C{G3} = $CHARSET{G94}->{"\x7E"};     ## empty set    $C{G3} = $CHARSET{G94}->{"\x7E"};     ## empty set
66      $C{coding_system} = $CODING_SYSTEM{"\x40"};   ## ISO/IEC 2022
67    $C{option} = {    $C{option} = {
68          C1invoke_to_right       => 0,   ## C1 invoked to: (0: ESC Fe, 1: CR)          C1invoke_to_right       => 0,   ## C1 invoked to: (0: ESC Fe, 1: CR)
69          G94n_designate_long     => 0,   ## (1: ESC 02/04 02/08 04/00..02)          G94n_designate_long     => 0,   ## (1: ESC 02/04 02/08 04/00..02)
# Line 235  sub new_object { Line 87  sub new_object {
87                  G96n    => {                  G96n    => {
88                          default => 1,                          default => 1,
89                  },                  },
90                    coding_system => {
91                            default => -1,
92                    },
93          },          },
94          Ginvoke_by_single_shift => [0,0,0,0],   ## Invoked by SS          Ginvoke_by_single_shift => [0,0,0,0],   ## Invoked by SS
95          Ginvoke_to_left => [1,1,1,1],   ## Which invoked to? (1: L, 0: R)          Ginvoke_to_left => [1,1,1,1],   ## Which invoked to? (1: L, 0: R)
# Line 254  sub new_object { Line 109  sub new_object {
109                  Gdesignation    => "\x42",      ## F of designation or 0                  Gdesignation    => "\x42",      ## F of designation or 0
110                  Ginvoke => 1,                  Ginvoke => 1,
111          },          },
112            undef_char      => ["\x3F", {type => 'G94', charset => 'B'}],
113          use_revision    => 1,   ## Output IRR          use_revision    => 1,   ## Output IRR
114    };    };
115    \%C;    \%C;
# Line 261  sub new_object { Line 117  sub new_object {
117    
118  sub iso2022_to_internal ($;\%) {  sub iso2022_to_internal ($;\%) {
119    my ($s, $C) = @_;    my ($s, $C) = @_;
120      my $t = '';
121      $s =~ s{
122        ^((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
123      }{
124        my $i2 = $1;
125        $t = _iso2022_to_internal ($i2, $C);
126        '';
127      }gesx;
128      $s =~ s{
129         ## ISO/IEC 2022
130          \x1B\x25\x40((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
131         ## UTF-8
132         |\x1B\x25(?:\x47|\x2F[\x47-\x49])((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
133         ## UCS-2, UTF-16
134         |\x1B\x25\x2F[\x40\x43\x45\x4A-\x4C]
135           ((?!\x00\x1B\x00\x25\x00\x2F?\x00[\x30-\x7E].)*)
136         ## UCS-4
137         |\x1B\x25\x2F[\x41\x44\x46]
138           ((?!\x00\x00\x00\x1B\x00\x00\x00\x25\x00\x00\x00\x2F?
139               \x00\x00\x00[\x30-\x7E].)*)
140         ## with standard return
141         |\x1B\x25([\x30-\x7E])((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
142         ## without standard return
143         |\x1B\x25\x2F([\x30-\x7E])(.*)
144      }{
145        my ($i2,$u8,$Fu2,$u2,$u4,$Fsr,$sr,$Fnsr,$nsr) = ($1,$2,$3,$4,$5,$6,$7,$8,$9);
146        my $r = '';
147        if (defined $i2) {
148          $r = _iso2022_to_internal ($i2, $C);
149        } elsif (defined $u8) {
150          $r = Encode::decode ('utf8', $u8);
151        } elsif ($Fu2) {
152          if (ord ($Fu2) > 0x49) {
153            $r = Encode::decode ('utf-16be', $u2);
154          } else {
155            $r = Encode::decode ('ucs-2be', $u2);
156          }
157        } elsif (defined $u4) {
158          $r = Encode::decode ('ucs-4be', $u2);
159        } else {    ## temporary
160          $r = '?+';
161        }
162        $r;
163      }gesx;
164      $t . $s;
165    }
166    
167    sub _iso2022_to_internal ($;\%) {
168      my ($s, $C) = @_;
169    my %_GB_to_GN = (    my %_GB_to_GN = (
170      "\x28"=>'G0',"\x29"=>'G1',"\x2A"=>'G2',"\x2B"=>'G3',      "\x28"=>'G0',"\x29"=>'G1',"\x2A"=>'G2',"\x2B"=>'G3',
171      "\x2C"=>'G0',"\x2D"=>'G1',"\x2E"=>'G2',"\x2F"=>'G3',      "\x2C"=>'G0',"\x2D"=>'G1',"\x2E"=>'G2',"\x2F"=>'G3',
# Line 295  sub iso2022_to_internal ($;\%) { Line 200  sub iso2022_to_internal ($;\%) {
200        ((??{ $_CHARS_to_RANGE{'b'.$C->{$C->{GL}}->{chars}}        ((??{ $_CHARS_to_RANGE{'b'.$C->{$C->{GL}}->{chars}}
201              . qq/{$C->{G3}->{dimension},$C->{G3}->{dimension}}/ }))              . qq/{$C->{G3}->{dimension},$C->{G3}->{dimension}}/ }))
202            
203      |((??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' }))  ## GL = G0      ## Locking shift
204      |((??{ $C->{$C->{CL}}->{r_LS1}||'(?!)' }))  ## GL = G1      |( \x1B[\x6E\x6F\x7C-\x7E]
205           |(??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' })
206           |(??{ $C->{$C->{CL}}->{r_LS1}||'(?!)' })
207         )
208            
209      ## Control sequence      ## Control sequence
210      |(??{ '(?:'.($C->{$C->{CR}}->{r_CSI}||'(?!)')      |(??{ '(?:'.($C->{$C->{CR}}->{r_CSI}||'(?!)')
# Line 314  sub iso2022_to_internal ($;\%) { Line 222  sub iso2022_to_internal ($;\%) {
222      ## Misc. sequence (SP, control, or broken data)      ## Misc. sequence (SP, control, or broken data)
223      |([\x00-\xFF])      |([\x00-\xFF])
224    }{    }{
225      my ($gl,$gr,$ss2,$ss3,$ls0,$ls1,$csi,$esc,$misc)      my ($gl,$gr,$ss2,$ss3,$ls,$csi,$esc,$misc)
226        = ($1,$2,$3,$4,$5,$6,$7,$8,$9,$10);        = ($1,$2,$3,$4,$5,$6,$7,$8,$9);
227      $C->{_irr} = undef unless defined $esc;      $C->{_irr} = undef unless defined $esc;
228      ## GL graphic character      ## GL graphic character
229      if (defined $gl) {      if (defined $gl) {
# Line 353  sub iso2022_to_internal ($;\%) { Line 261  sub iso2022_to_internal ($;\%) {
261          $c = $c * $C->{G3}->{chars} + unpack ('C', $_) - $m;          $c = $c * $C->{G3}->{chars} + unpack ('C', $_) - $m;
262        }        }
263        chr ($C->{G3}->{ucs} + $c);        chr ($C->{G3}->{ucs} + $c);
     ## Locking shifts  
       } elsif ($ls0) {  
         $C->{GL} = 'G0'; '';  
       } elsif ($ls1) {  
         $C->{GL} = 'G1'; '';  
264      ## Escape sequence      ## Escape sequence
265      } elsif ($esc) {      } elsif ($esc) {
266        ## IRR (revision number)        ## IRR (revision number)
# Line 434  sub iso2022_to_internal ($;\%) { Line 337  sub iso2022_to_internal ($;\%) {
337          $C->{_irr} = undef;          $C->{_irr} = undef;
338        }        }
339        $esc;        $esc;
340        ## Locking shifts
341        } elsif ($ls) {
342          if ($ls eq $C->{$C->{CL}}->{LS0}) {
343            $C->{GL} = 'G0'; '';
344          } elsif ($ls eq $C->{$C->{CL}}->{LS1}) {
345            $C->{GL} = 'G1'; '';
346          } elsif ($ls =~ /\x1B([\x6E\x6F])/) {
347            $C->{GL} = {"\x6E"=>2, "\x6F"=>3}->{$1}; '';
348          } elsif ($ls =~ /\x1B([\x7C-\x7E])/) {
349            $C->{GR} = {"\x7E"=>1, "\x7D"=>2, "\x7C"=>3}->{$1}; '';
350          }
351      ## Control sequence      ## Control sequence
352      } elsif ($csi) {      } elsif ($csi) {
353        $csi =~ tr/\xA0-\xFF/\x20-\x7F/d;        $csi =~ tr/\xA0-\xFF/\x20-\x7F/d;
# Line 560  sub internal_to_iso2022 ($\%) { Line 474  sub internal_to_iso2022 ($\%) {
474                         ->[ $c / 8836 ]);                         ->[ $c / 8836 ]);
475      }      }
476      if (defined $t) {      if (defined $t) {
477          $t = _i2o ($t, $C, cs_F => "\x40")
478            if $C->{coding_system} ne $CODING_SYSTEM{"\x40"};
479        } else {
480          my $F;  my @F = qw~G /G /H /I  B  /A /D /F~;
481          push @F, qw~/J /K /L~ if $cc <= 0x10FFFF;
482          push @F, qw~/@ /C /E~ if $cc <= 0xFFFF;
483          for (@F) {
484            if (defined $C->{option}->{designate_to}->{coding_system}->{$_}
485                && $C->{option}->{designate_to}->{coding_system}->{$_} > -1) {
486              $F = $_; last;
487            } elsif ($C->{option}->{designate_to}->{coding_system}->{default} > -1) {
488              $F = $_; last;
489            }
490          }
491          $t = _i2o ($c, $C, cs_F => $F) if $F;
492        }
493        if (defined $t) {
494        $r .= $t;        $r .= $t;
495      } else {      } else {
496        $r .= _i2g ("\x3F", $C, type => 'G94', charset => 'B');        $t = _i2g ($C->{option}->{undef_char}->[0], $C,
497                      %{ $C->{option}->{undef_char}->[1] });
498          $r .= $C->{coding_system} eq $CODING_SYSTEM{"\x40"} ?
499                $t : _i2o ($t, $C, cs_F => "\x40");
500      }      }
501    }    }
502    $r . _back2ascii ($C);    $r . _back2ascii ($C);
# Line 616  sub _i2c ($%%) { Line 550  sub _i2c ($%%) {
550  sub _i2g ($%%) {  sub _i2g ($%%) {
551    my ($s, $C, %O) = @_;    my ($s, $C, %O) = @_;
552    my $r = '';    my $r = '';
553    my $set = $CHARSET{$O{type}}->{$O{charset}};    my $set = $CHARSET{$O{type}}->{$O{charset}.
554        ($O{revision}&&$C->{option}->{use_revision}?$O{revision}:'')};
555    my $set0 = $CHARSET{$O{type}}->{$O{charset_id}};    my $set0 = $CHARSET{$O{type}}->{$O{charset_id}};
556    ## -- designate character set    ## -- designate character set
557    my $G = 0;    my $G = 0;
# Line 670  sub _i2g ($%%) { Line 605  sub _i2g ($%%) {
605        } elsif ($C->{C0}->{'C_SS'.$G}) {        } elsif ($C->{C0}->{'C_SS'.$G}) {
606          $r .= _i2c ($C->{C0}->{'C_SS'.$G}, $C, type => 'C0') || return undef;          $r .= _i2c ($C->{C0}->{'C_SS'.$G}, $C, type => 'C0') || return undef;
607        } else {  ## Both C0 and C1 set do not have SS2/3.        } else {  ## Both C0 and C1 set do not have SS2/3.
608            $left = 0 if $G == 1 && !$C->{C0}->{C_LS1};
609          $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;
610        }        }
611      } else {      } else {
# Line 716  sub __invoke (\%$$) { Line 652  sub __invoke (\%$$) {
652    }    }
653    '';    '';
654  }  }
655    sub _i2o ($\%%) {
656  sub make_charset (%) {    my ($s, $C, %O) = @_;
657  ## TODO: support private charset ID such as 'X0'    my $CS = $CODING_SYSTEM{ $O{cs_F} } || $CODING_SYSTEM{ $O{cs_id} } || return undef;
658    my %set = @_;    my $r = '';
659    my $setid = qq($set{I}$set{F}$set{revision});    if ($CS ne $C->{coding_system}) {
660    my $settype = $set{type} || 'G94';      my $e = '';
661    delete $set{type}, $set{I}, $set{F}, $set{revision};      $e .= "\x1B\x25";
662    $CHARSET{ $settype }->{ $setid } = \%set;      $e .= $O{cs_F} || $C->{private_set}->{coding_system}->{ $O{cs_id} }
663              || return undef;
664        if ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x40"}
665         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x43"}
666         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x45"}
667         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4A"}
668         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4B"}
669         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4C"}) {
670          $e =~ s/(.)/\x00$1/go;
671        } elsif ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x41"}
672         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x44"}
673         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x46"}) {
674          $e =~ s/(.)/\x00\x00\x00$1/go;
675        }
676        $r .= $e;
677        $C->{coding_system} = $CS;
678        if ($CS->{reset_state}) {
679          $C->{GL} = undef;  $C->{GR} = undef;
680          $C->{C0} = $CHARSET{C0}->{"\x7E"};
681          $C->{C1} = $CHARSET{C1}->{"\x7E"};
682          $C->{G0} = $CHARSET{G94}->{"\x7E"};
683          $C->{G1} = $CHARSET{G94}->{"\x7E"};
684          $C->{G2} = $CHARSET{G94}->{"\x7E"};
685          $C->{G3} = $CHARSET{G94}->{"\x7E"};
686        }
687      }
688      if ($CS eq $CODING_SYSTEM{"\x40"}) {
689        #
690      } elsif ($CS eq $CODING_SYSTEM{G} || $CS eq $CODING_SYSTEM{'/G'}
691            || $CS eq $CODING_SYSTEM{'/H'} || $CS eq $CODING_SYSTEM{'/I'}) {
692        Encode::_utf8_off ($s);
693      } elsif ($CS eq $CODING_SYSTEM{'/@'} || $CS eq $CODING_SYSTEM{'/C'}
694            || $CS eq $CODING_SYSTEM{'/E'}) {
695        $s = Encode::encode ('ucs-2be', $s);
696      } elsif ($CS eq $CODING_SYSTEM{'/A'} || $CS eq $CODING_SYSTEM{'/D'}
697            || $CS eq $CODING_SYSTEM{'/F'}) {
698        $s = Encode::encode ('ucs-4be', $s);
699      } elsif ($CS eq $CODING_SYSTEM{'/J'} || $CS eq $CODING_SYSTEM{'/K'}
700            || $CS eq $CODING_SYSTEM{'/L'}) {
701        $s = Encode::encode ('UTF-16BE', $s);
702      } elsif ($CS eq $CODING_SYSTEM{B}) {
703        $s = Encode::encode ('utf-1', $s);
704      } else {
705        return undef;
706      }
707      $r . $s;
708  }  }
709    
710  1;  1;
# Line 746  ISO/IEC 8859, "8-Bit Single-Byte Coded G Line 727  ISO/IEC 8859, "8-Bit Single-Byte Coded G
727    
728  Encode, perlunicode  Encode, perlunicode
729    
730    =head1 TODO
731    
732    =over 4
733    
734    =item NCR (coding system other than ISO/IEC 2022) support
735    
736    =over 2
737    
738    =item ESC 02/05 02/15 03/x of X Compound Text
739    
740    =back
741    
742    =item Output of control character sets, single control functions
743    
744    =item Designation sequence of control character sets (input)
745    
746    =item Special graphic character sets such as G3 of EUC-TW
747    
748    =item SUPER SHIFT (SS) invoke function of old control character set
749    
750    =item Safe transparent of control string (ISO/IEC 6429)
751    
752    =item Output of unoutputable characters as alternative notation such as SGML-like entity
753    
754    =item C0 set invoked to CR area like ISIRI code
755    
756    Really need?
757    
758    =item special treatment of 0x20, 0x7E, 0xA0, 0xFF
759    
760    For example, GB mongolian sets use MSP (MONGOLIAN SPACE)
761    with these code positions.
762    
763    And, no less coding systems does not use (or does ban using) DEL.
764    
765    =item A lot of character sets don't have pseudo-UCS mapping.
766    
767    Most of 9m^n (n >= 3) sets, 9m^n sets with I byte, 9m^n
768    DRCSes do not have pseudo-UCS mapping area.  It is
769    questionable to allocate lots of code positions to these
770    rarely-(or no-)used character sets.
771    
772    =item Even character sets that have pseudo-UCS mapping, some of them can't be outputed in ISO/IEC 2022.
773    
774    Because output of rarely-used character sets is
775    not implemented yet.
776    
777    =back
778    
779    =head1 AUTHORS
780    
781    Nanashi-san
782    
783    Wakaba <w@suika.fam.cx>
784    
785  =head1 LICENSE  =head1 LICENSE
786    
787  Copyright 2002 wakaba <w@suika.fam.cx>  Copyright 2002 AUTHORS
788    
789  This library is free software; you can redistribute it  This library is free software; you can redistribute it
790  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.5
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24