/[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.4 by wakaba, Mon Sep 16 06:35:16 2002 UTC revision 1.9 by wakaba, Mon Oct 14 06:58: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 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};  
 }  
   
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;
 ## Make a new ISO/IEC 2022-buffers object with default status  
 sub new_object {  
   my %C;  
   $C{bit} = 8;  
   $C{CL} = 'C0'; $C{CR} = 'C1'; $C{ESC_Fe} = 'C1';  
   $C{C0} = $CHARSET{C0}->{"\x40"};      ## ISO/IEC 6429:1991 C0  
   $C{C1} = $CHARSET{C1}->{'64291991C1'};        ## ISO/IEC 6429:1991 C1  
   $C{GL} = 'G0'; $C{GR} = 'G1';  
   $C{G0} = $CHARSET{G94}->{"\x42"};     ## ISO/IEC 646:1991 IRV  
   #$C{G1} = $CHARSET{G96}->{"\x41"};    ## ISO/IEC 8859-1 GR  
   $C{G1} = $CHARSET{G94}->{"\x7E"};     ## empty set  
   $C{G2} = $CHARSET{G94}->{"\x7E"};     ## empty set  
   $C{G3} = $CHARSET{G94}->{"\x7E"};     ## empty set  
   $C{option} = {  
         C1invoke_to_right       => 0,   ## C1 invoked to: (0: ESC Fe, 1: CR)  
         G94n_designate_long     => 0,   ## (1: ESC 02/04 02/08 04/00..02)  
         designate_to    => {    ## Designated G buffer (-1: not be outputed)  
                 C0      => {  
                         default => 0,  
                 },  
                 C1      => {  
                         default => 1,  
                 },  
                 G94     => {  
                         "\x42"  => 0,  
                         default => 0,  
                 },  
                 G96     => {  
                         default => 1,  
                 },  
                 G94n    => {  
                         default => 0,  
                 },  
                 G96n    => {  
                         default => 1,  
                 },  
         },  
         Ginvoke_by_single_shift => [0,0,0,0],   ## Invoked by SS  
         Ginvoke_to_left => [1,1,1,1],   ## Which invoked to? (1: L, 0: R)  
         private_set     => {    ## Private set vs Final byte  
                 C0      => [],  
                 C1      => [],  
                 G94     => [],  
                 G94n    => [[],[],[],[],[]],  
                 G96     => [],  
                 #G96n   => [],  ## (not implemented)  
                 U96n    => [],  ## mule-unicode sets  
                 XC1     => {  
                         '64291991C1'    => undef,       ## ISO/IEC 6429:1991 C1  
                 },  
         },  
         reset => {      ## Reset status at top of line  
                 Gdesignation    => "\x42",      ## F of designation or 0  
                 Ginvoke => 1,  
         },  
         undef_char      => ["\x3F", {type => 'G94', charset => 'B'}],  
         use_revision    => 1,   ## Output IRR  
   };  
   \%C;  
 }  
68    
69  sub iso2022_to_internal ($;\%) {  sub iso2022_to_internal ($;\%) {
70    my ($s, $C) = @_;    my ($s, $C) = @_;
71      $C ||= &new_object;
72      my $t = '';
73      $s =~ s{^((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)}{
74        my $i2 = $1;
75        $t = _iso2022_to_internal ($i2, $C);
76        '';
77      }es;
78      my $pad = '';
79      use re 'eval';
80      $s =~ s{
81         ## ISO/IEC 2022
82          (??{"$pad\x1B$pad\x25$pad\x40"})((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
83         ## UTF-8
84         |(??{"$pad\x1B$pad\x25$pad(?:\x47|\x2F$pad"."[\x47-\x49])"})
85           ((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
86         ## UCS-2, UTF-16
87         |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})([\x40\x43\x45\x4A-\x4C])
88           ((?:(?!\x00\x1B\x00\x25(?:\x00\x2F)?\x00[\x30-\x7E])..)*)
89         ## UCS-4
90         |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})[\x41\x44\x46]
91           ((?:(?!\x00\x00\x00\x1B\x00\x00\x00\x25(?:\x00\x00\x00\x2F)?
92               \x00\x00\x00[\x30-\x7E])....)*)
93         ## with standard return
94         |(??{"$pad\x1B$pad\x25$pad"})([\x30-\x7E])
95           ((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)
96         ## without standard return
97         |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})([\x30-\x7E])(.*)
98      }{
99        my ($i2,$u8,$Fu2,$u2,$u4,$Fsr,$sr,$Fnsr,$nsr) = ($1,$2,$3,$4,$5,$6,$7,$8,$9);
100        my $r = '';
101        if (defined $i2) {
102          $r = _iso2022_to_internal ($i2, $C);  $pad = '';
103        } elsif (defined $u8) {
104          $r = Encode::decode ('utf8', $u8);  $pad = '';
105        } elsif ($Fu2) {
106          if (ord ($Fu2) > 0x49) {
107            $r = Encode::decode ('utf-16be', $u2);
108          } else {
109            $r = Encode::decode ('ucs-2be', $u2);
110          }
111          $pad = "\x00";
112        } elsif (defined $u4) {
113          $r = Encode::decode ('ucs-4be', $u2);  $pad = "\x00\x00\x00";
114        } elsif (defined $Fsr && $CODING_SYSTEM{$Fsr}->{perl_name}) {
115          $r = Encode::decode ($CODING_SYSTEM{$Fsr}->{perl_name}, $sr);  $pad = '';
116        } elsif (defined $Fnsr && $CODING_SYSTEM{$Fnsr}->{perl_name}) {
117          $r = Encode::decode ($CODING_SYSTEM{$Fnsr}->{perl_name}, $nsr);  $pad = '';
118        } else {    ## temporary
119          $r = '?' x length ($sr.$nsr);  $pad = '';
120        }
121        $r;
122      }gesx;
123      $t . $s;
124    }
125    
126    # 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    # 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) = @_;
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 283  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 293  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      ## Locking shift      ## Locking shift
178      |( \x1B[\x6E\x6F\x7C-\x7E]      |(  (??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' })
        |(??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' })  
179         |(??{ $C->{$C->{CL}}->{r_LS1}||'(?!)' })         |(??{ $C->{$C->{CL}}->{r_LS1}||'(?!)' })
180       )       )
181            
# Line 413  sub iso2022_to_internal ($;\%) { Line 290  sub iso2022_to_internal ($;\%) {
290                $C->{GL} = 'G2'; '';                $C->{GL} = 'G2'; '';
291              } elsif ($Fs eq "\x6F") {   ## LS3              } elsif ($Fs eq "\x6F") {   ## LS3
292                $C->{GL} = 'G3'; '';                $C->{GL} = 'G3'; '';
293              } elsif ($Fs eq "\x7E") {   ## LS1R              } elsif ($Fs eq "\x7E" || $Fs eq "\x6B") {  ## LS1R
294                $C->{GR} = 'G1';  $C->{GL} = 'G1' if $C->{bit} == 7; '';                $C->{GR} = 'G1';  $C->{GL} = 'G1' if $C->{bit} == 7; '';
295              } elsif ($Fs eq "\x7D") {   ## LS2R              } elsif ($Fs eq "\x7D" || $Fs eq "\x6C") {  ## LS2R
296                $C->{GR} = 'G2';  $C->{GL} = 'G2' if $C->{bit} == 7; '';                $C->{GR} = 'G2';  $C->{GL} = 'G2' if $C->{bit} == 7; '';
297              } elsif ($Fs eq "\x7C") {   ## LS3R              } elsif ($Fs eq "\x7C" || $Fs eq "\x6D") {  ## LS3R
298                $C->{GR} = 'G3';  $C->{GL} = 'G3' if $C->{bit} == 7; '';                $C->{GR} = 'G3';  $C->{GL} = 'G3' if $C->{bit} == 7; '';
299              } else {              } else {
300                chr ($CHARSET{single_control}->{Fs}->{ucs} + (ord ($Fs) - 0x60));                chr ($CHARSET{single_control}->{Fs}->{ucs} + (ord ($Fs) - 0x60));
# Line 439  sub iso2022_to_internal ($;\%) { Line 316  sub iso2022_to_internal ($;\%) {
316          $C->{GL} = 'G0'; '';          $C->{GL} = 'G0'; '';
317        } elsif ($ls eq $C->{$C->{CL}}->{LS1}) {        } elsif ($ls eq $C->{$C->{CL}}->{LS1}) {
318          $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}; '';  
319        }        }
320      ## Control sequence      ## Control sequence
321      } elsif ($csi) {      } elsif ($csi) {
# Line 451  sub iso2022_to_internal ($;\%) { Line 324  sub iso2022_to_internal ($;\%) {
324        $csi =~ s/$C->{$C->{CL}}->{LS1}//g if $C->{$C->{CL}}->{LS1};        $csi =~ s/$C->{$C->{CL}}->{LS1}//g if $C->{$C->{CL}}->{LS1};
325        "\x9B".$csi;        "\x9B".$csi;
326      }      }
327    }gex;    }gesx;
328    $s;    $s;
329  }  } # __iso2022_to_internal
330    
331      };
332      &__iso2022_to_internal (@_) if defined $_[0];
333    
334    } # _iso2022_to_internal
335    
336  sub internal_to_iso2022 ($\%) {  sub internal_to_iso2022 ($\%) {
337    my ($s, $C) = @_;    my ($s, $C) = @_;
# Line 461  sub internal_to_iso2022 ($\%) { Line 339  sub internal_to_iso2022 ($\%) {
339        
340    my $r = '';    my $r = '';
341    for my $c (split //, $s) {    for my $c (split //, $s) {
342      my $cc = ord $c;      my $cc = ord $c;  Encode::_utf8_off ($c);
343      my $t;      my $t;
344      if ($cc <= 0x1F) {      if ($cc <= 0x1F) {
345        $t = _i2c ($c, $C, type => 'C0', charset => '@');        $t = _i2c ($c, $C, type => 'C0', charset => '@');
# Line 471  sub internal_to_iso2022 ($\%) { Line 349  sub internal_to_iso2022 ($\%) {
349        $t = _i2g ($c, $C, type => 'G94', charset => 'B');        $t = _i2g ($c, $C, type => 'G94', charset => 'B');
350      } elsif ($cc <= 0x9F) {      } elsif ($cc <= 0x9F) {
351        $t = _i2c ($c, $C, type => 'C1', charset_id => '64291991C1',        $t = _i2c ($c, $C, type => 'C1', charset_id => '64291991C1',
352          charset => $C->{private_set}->{XC1}->{'64291991C1'});          charset => $C->{option}->{private_set}->{XC1}->{'64291991C1'});
353      } elsif ($cc <= 0xFF) {      } elsif ($cc <= 0xFF) {
354        $t = _i2g (chr($cc-0x80), $C, type => 'G96', charset => 'A');        $t = _i2g (chr($cc-0x80), $C, type => 'G96', charset => 'A');
355      } elsif ($cc <= 0x24FF) {      } elsif ($cc <= 0x24FF) {
356        my $c = $cc - 0x100;        my $c = $cc - 0x100;
357        my $final = $C->{private_set}->{U96n}->[0];        my $final = $C->{option}->{private_set}->{U96n}->[0];
358        if (length $final) {        if (length $final) {
359          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
360            type => 'G96n', charset => $final);            type => 'G96n', charset => $final);
361        }        }
362      } elsif ($cc <= 0x33FF) {      } elsif ($cc <= 0x33FF) {
363        my $c = $cc - 0x2500;        my $c = $cc - 0x2500;
364        my $final = $C->{private_set}->{U96n}->[1];        my $final = $C->{option}->{private_set}->{U96n}->[1];
365        if (length $final) {        if (length $final) {
366          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
367            type => 'G96n', charset => $final);            type => 'G96n', charset => $final);
368        }        }
369      } elsif (0xE000 <= $cc && $cc <= 0xFFFF) {      } elsif (0xE000 <= $cc && $cc <= 0xFFFF) {
370        my $c = $cc - 0xE000;        my $c = $cc - 0xE000;
371        my $final = $C->{private_set}->{U96n}->[2];        my $final = $C->{option}->{private_set}->{U96n}->[2];
372        if (length $final) {        if (length $final) {
373          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,          $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C,
374            type => 'G96n', charset => $final);            type => 'G96n', charset => $final);
# Line 556  sub internal_to_iso2022 ($\%) { Line 434  sub internal_to_iso2022 ($\%) {
434      } elsif (0x70400000 <= $cc && $cc <= 0x7040FFED) {      } elsif (0x70400000 <= $cc && $cc <= 0x7040FFED) {
435        my $c = $cc - 0x70400000;        my $c = $cc - 0x70400000;
436        $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),
437            type => 'G94', charset => $C->{private_set}->{G94}->[ $c / 94 ]);            type => 'G94', charset => $C->{option}->{private_set}->{G94}->[ $c / 94 ]);
438      } elsif (0x70410000 <= $cc && $cc <= 0x7041FFBF) {      } elsif (0x70410000 <= $cc && $cc <= 0x7041FFBF) {
439        my $c = $cc - 0x70410000;        my $c = $cc - 0x70410000;
440        $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),
441            type => 'G96', charset => $C->{private_set}->{G96}->[ $c / 96 ]);            type => 'G96', charset => $C->{option}->{private_set}->{G96}->[ $c / 96 ]);
442      } elsif (0x70420000 <= $cc && $cc <= 0x7046F19B) {      } elsif (0x70420000 <= $cc && $cc <= 0x7046F19B) {
443        my $c = $cc % 0x10000;        my $c = $cc % 0x10000;
444        $t = _i2g (chr((($c % 8836) / 94)+0x21).chr(($c % 94)+0x21), $C,        $t = _i2g (chr((($c % 8836) / 94)+0x21).chr(($c % 94)+0x21), $C,
445            type => 'G94n',            type => 'G94n',
446            charset_id => 'P'.int(($cc / 0x10000) - 0x7042).'_'.int($c / 8836),            charset_id => 'P'.int(($cc / 0x10000) - 0x7042).'_'.int($c / 8836),
447            charset => $C->{private_set}->{G94n}->[ ($cc / 0x10000) - 0x7042 ]            charset => $C->{option}->{private_set}->{G94n}
448                         ->[ $c / 8836 ]);                         ->[ ($cc / 0x10000) - 0x7042 ]->[ $c / 8836 ]);
449        }
450        if (defined $t) {
451          $t = _i2o ($t, $C, cs_F => "\x40")
452            if $C->{coding_system} ne $CODING_SYSTEM{"\x40"};
453        } else {
454          my $F;  my @F = qw~G /G /H /I  B  /A /D /F~;
455          push @F, qw~/J /K /L~ if $cc <= 0x10FFFF;
456          push @F, qw~/@ /C /E~ if $cc <= 0xFFFF;
457          for (@F) {
458            if (defined $C->{option}->{designate_to}->{coding_system}->{$_}
459                && $C->{option}->{designate_to}->{coding_system}->{$_} > -1) {
460              $F = $_; last;
461            } elsif ($C->{option}->{designate_to}->{coding_system}->{default} > -1) {
462              $F = $_; last;
463            }
464          }
465          $t = _i2o ($c, $C, cs_F => $F) if $F;
466      }      }
467      if (defined $t) {      if (defined $t) {
468        $r .= $t;        $r .= $t;
469      } else {      } else {
470        $r .= _i2g ($C->{option}->{undef_char}->[0], $C,        unless ($C->{option}->{undef_char}->[0] eq "\x20") {
471                    %{ $C->{option}->{undef_char}->[1] });          $t = _i2g ($C->{option}->{undef_char}->[0], $C,
472                        %{ $C->{option}->{undef_char}->[1] });
473          } else {  ## SP
474            $t = _back2ascii ($C) . "\x20";
475          }
476          $r .= $C->{coding_system} eq $CODING_SYSTEM{"\x40"} ?
477                $t : _i2o ($t, $C, cs_F => "\x40");
478      }      }
479    }    }
480    $r . _back2ascii ($C);    $r . _back2ascii ($C);
# Line 729  sub __invoke (\%$$) { Line 630  sub __invoke (\%$$) {
630    }    }
631    '';    '';
632  }  }
633    sub _i2o ($\%%) {
634  sub make_charset (%) {    my ($s, $C, %O) = @_;
635  ## TODO: support private charset ID such as 'X0'    my $CS = $CODING_SYSTEM{ $O{cs_F} } || $CODING_SYSTEM{ $O{cs_id} } || return undef;
636    my %set = @_;    my $r = '';
637    my $setid = qq($set{I}$set{F}$set{revision});    if ($CS ne $C->{coding_system}) {
638    my $settype = $set{type} || 'G94';      my $e = '';
639    delete $set{type}, $set{I}, $set{F}, $set{revision};      $e .= "\x1B\x25";
640    $CHARSET{ $settype }->{ $setid } = \%set;      $e .= $O{cs_F} || $C->{option}->{private_set}->{coding_system}->{ $O{cs_id} }
641              || return undef;
642        if ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x40"}
643         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x43"}
644         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x45"}
645         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4A"}
646         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4B"}
647         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4C"}) {
648          $e =~ s/(.)/\x00$1/go;
649        } elsif ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x41"}
650         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x44"}
651         || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x46"}) {
652          $e =~ s/(.)/\x00\x00\x00$1/go;
653        }
654        $r .= $e;
655        $C->{coding_system} = $CS;
656        if ($CS->{reset_state}) {
657          $C->{GL} = undef;  $C->{GR} = undef;
658          $C->{C0} = $CHARSET{C0}->{"\x7E"};
659          $C->{C1} = $CHARSET{C1}->{"\x7E"};
660          $C->{G0} = $CHARSET{G94}->{"\x7E"};
661          $C->{G1} = $CHARSET{G94}->{"\x7E"};
662          $C->{G2} = $CHARSET{G94}->{"\x7E"};
663          $C->{G3} = $CHARSET{G94}->{"\x7E"};
664        }
665      }
666      if ($CS eq $CODING_SYSTEM{"\x40"}) {
667        #
668      } elsif ($CS eq $CODING_SYSTEM{G} || $CS eq $CODING_SYSTEM{'/G'}
669            || $CS eq $CODING_SYSTEM{'/H'} || $CS eq $CODING_SYSTEM{'/I'}) {
670        Encode::_utf8_off ($s);
671      } elsif ($CS eq $CODING_SYSTEM{'/@'} || $CS eq $CODING_SYSTEM{'/C'}
672            || $CS eq $CODING_SYSTEM{'/E'}) {
673        $s = Encode::encode ('ucs-2be', $s);
674      } elsif ($CS eq $CODING_SYSTEM{'/A'} || $CS eq $CODING_SYSTEM{'/D'}
675            || $CS eq $CODING_SYSTEM{'/F'}) {
676        $s = Encode::encode ('ucs-4be', $s);
677      } elsif ($CS eq $CODING_SYSTEM{'/J'} || $CS eq $CODING_SYSTEM{'/K'}
678            || $CS eq $CODING_SYSTEM{'/L'}) {
679        $s = Encode::encode ('UTF-16BE', $s);
680      } elsif ($CS eq $CODING_SYSTEM{B}) {
681        $s = Encode::encode ('utf-1', $s);
682      } else {
683        return undef;
684      }
685      $r . $s;
686  }  }
687    
688  1;  1;
# Line 808  not implemented yet. Line 754  not implemented yet.
754    
755  =back  =back
756    
757    =head1 AUTHORS
758    
759    Nanashi-san
760    
761    Wakaba <w@suika.fam.cx>
762    
763  =head1 LICENSE  =head1 LICENSE
764    
765  Copyright 2002 wakaba <w@suika.fam.cx>  Copyright 2002 AUTHORS
766    
767  This library is free software; you can redistribute it  This library is free software; you can redistribute it
768  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.4  
changed lines
  Added in v.1.9
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24