--- perl/lib/Encode/ISO2022.pm 2002/09/16 06:35:16 1.4 +++ perl/lib/Encode/ISO2022.pm 2002/12/18 10:21:09 1.14 @@ -3,184 +3,50 @@ Encode::ISO2022 --- ISO/IEC 2022 encoder and decoder -=cut +=head1 ENCODINGS -require v5.7.3; -package Encode::ISO2022; -use strict; -use vars qw(%CHARSET $VERSION); -$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; -use base qw(Encode::Encoding); -__PACKAGE__->Define (qw/iso-2022 iso2022 2022 cp2022/); +=over 4 -### --- Intialization +=item iso2022 -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 (04/00-04/14) (DRCS) -} +ISO/IEC 2022:1994. Default status is: -$CHARSET{G94}->{B}->{ucs} = 0x21; ## ASCII -$CHARSET{G96}->{A}->{ucs} = 0xA0; ## ISO 8859-1 +=over 2 -$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}; -} +=item CL = C0 = ISO/IEC 6429:1991 C0 set + +=item CR = C1 = ISO/IEC 6429:1991 C1 set + +=item GL = G0 = ISO/IEC 646:1991 IRV GL(G0) set + +=item GR = G1 = empty set + +=item G2 = empty set + +=item G3 = empty set +=back + +(Alias: iso/iec2022, iso-2022, 2022, cp2022) + +=back + +Note that ISO/IEC 2022 based encodings are found in +Encode::ISO2022::* modules. This module, Encode::ISO2022 +only provides a general ISO/IEC 2022 encoder/decoder. + +=cut + +require v5.7.3; +package Encode::ISO2022; +use strict; +use vars qw(%CHARSET %CODING_SYSTEM $VERSION); +$VERSION=do{my @r=(q$Revision: 1.14 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; +use base qw(Encode::Encoding); +__PACKAGE__->Define (qw!iso-2022 iso/iec2022 iso2022 2022 cp2022!); +require Encode::Charset; + *CHARSET = \%Encode::Charset::CHARSET; + *CODING_SYSTEM = \%Encode::Charset::CODING_SYSTEM; ### --- Perl Encode module common functions @@ -198,83 +64,95 @@ } ### --- Encode::ISO2022 unique functions +*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; -} - -sub iso2022_to_internal ($;\%) { +sub iso2022_to_internal ($;%) { + my ($s, $C) = @_; + $C ||= &new_object; + my $t = ''; + $s =~ s{^((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*)}{ + my $i2 = $1; + $t = _iso2022_to_internal ($i2, $C); + ''; + }es; + my $pad = ''; + use re 'eval'; + $s =~ s{ + ## ISO/IEC 2022 + (??{"$pad\x1B$pad\x25$pad\x40"})((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*) + ## UTF-8 + |(??{"$pad\x1B$pad\x25$pad(?:\x47|\x2F$pad"."[\x47-\x49])"}) + ((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*) + ## UCS-2, UTF-16 + |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})([\x40\x43\x45\x4A-\x4C]) + ((?:(?!\x00\x1B\x00\x25(?:\x00\x2F)?\x00[\x30-\x7E])..)*) + ## UCS-4 + |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})[\x41\x44\x46] + ((?:(?!\x00\x00\x00\x1B\x00\x00\x00\x25(?:\x00\x00\x00\x2F)? + \x00\x00\x00[\x30-\x7E])....)*) + ## with standard return + |(??{"$pad\x1B$pad\x25$pad"})([\x30-\x7E]) + ((?:(?!\x1B\x25\x2F?[\x30-\x7E]).)*) + ## without standard return + |(??{"$pad\x1B$pad\x25$pad\x2F$pad"})([\x30-\x7E])(.*) + }{ + my ($i2,$u8,$Fu2,$u2,$u4,$Fsr,$sr,$Fnsr,$nsr) = ($1,$2,$3,$4,$5,$6,$7,$8,$9); + my $r = ''; + if (defined $i2) { + $r = _iso2022_to_internal ($i2, $C); $pad = ''; + } elsif (defined $u8) { + $r = Encode::decode ('utf8', $u8); $pad = ''; + } elsif ($Fu2) { + if (ord ($Fu2) > 0x49) { + $r = Encode::decode ('utf-16be', $u2); + } else { + $r = Encode::decode ('ucs-2be', $u2); + } + $pad = "\x00"; + } elsif (defined $u4) { + $r = Encode::decode ('ucs-4be', $u2); $pad = "\x00\x00\x00"; + } elsif (defined $Fsr && $CODING_SYSTEM{$Fsr}->{perl_name}) { + $r = Encode::decode ($CODING_SYSTEM{$Fsr}->{perl_name}, $sr); $pad = ''; + } elsif (defined $Fnsr && $CODING_SYSTEM{$Fnsr}->{perl_name}) { + $r = Encode::decode ($CODING_SYSTEM{$Fnsr}->{perl_name}, $nsr); $pad = ''; + } else { ## temporary + $r = '?' x length ($sr.$nsr); $pad = ''; + } + $r; + }gesx; + $t . $s; +} + +# this is very very trickey. my perl 5.8.0 does not process +# regex with eval except the first time (i think it's a bug +# of perl), so we redefine this function whenever being called! +# when this unexpected behavior is fixed or someone finds +# better way to avoid it, we will rewrite this code. +&_iso2022_to_internal (undef); +sub _iso2022_to_internal ($;%) { + eval q{ sub __iso2022_to_internal ($;%) { 0 } }; + eval q{ +sub __iso2022_to_internal ($;%) { + use re 'eval'; my ($s, $C) = @_; my %_GB_to_GN = ( "\x28"=>'G0',"\x29"=>'G1',"\x2A"=>'G2',"\x2B"=>'G3', "\x2C"=>'G0',"\x2D"=>'G1',"\x2E"=>'G2',"\x2F"=>'G3', ); - $C ||= &new_object; + 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]/, + ); - use re 'eval'; $s =~ s{ ((??{ $_CHARS_to_RANGE{'l'.$C->{$C->{GL}}->{chars}} . qq/{$C->{$C->{GL}}->{dimension},$C->{$C->{GL}}->{dimension}}/ })) - |((??{ $_CHARS_to_RANGE{'r'.$C->{$C->{GL}}->{chars}} - . qq/{$C->{$C->{GR}}->{dimension},$C->{$C->{GR}}->{dimension}}/ })) - + |((??{ $_CHARS_to_RANGE{'r'.$C->{$C->{GR}}->{chars}} + . qq/{$C->{$C->{GR}}->{dimension},$C->{$C->{GR}}->{dimension}}/ })) | (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS2} || '(?!)') . ($C->{$C->{ESC_Fe}}->{r_SS2_ESC} ? qq/|$C->{$C->{ESC_Fe}}->{r_SS2_ESC}/ : '') @@ -283,8 +161,8 @@ ||$C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9 qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'') }) - ((??{ $_CHARS_to_RANGE{'b'.$C->{$C->{GL}}->{chars}} - . qq/{$C->{G2}->{dimension},$C->{G2}->{dimension}}/ })) + ((??{ $_CHARS_to_RANGE{'b'.$C->{G2}->{chars}} + . qq/{$C->{G2}->{dimension},$C->{G2}->{dimension}}/ })) | (??{ q/(?:/ . ($C->{$C->{CR}}->{r_SS3} || '(?!)') . ($C->{$C->{ESC_Fe}}->{r_SS3_ESC} ? qq/|$C->{$C->{ESC_Fe}}->{r_SS3_ESC}/ : '') @@ -293,12 +171,11 @@ || $C->{$C->{CL}}->{r_LS1}? ## ISO/IEC 6429:1992 9 qq/[$C->{$C->{CL}}->{r_LS0}$C->{$C->{CL}}->{r_LS1}]*/:'') }) - ((??{ $_CHARS_to_RANGE{'b'.$C->{$C->{GL}}->{chars}} + ((??{ $_CHARS_to_RANGE{'b'.$C->{G3}->{chars}} . qq/{$C->{G3}->{dimension},$C->{G3}->{dimension}}/ })) ## Locking shift - |( \x1B[\x6E\x6F\x7C-\x7E] - |(??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' }) + |( (??{ $C->{$C->{CL}}->{r_LS0}||'(?!)' }) |(??{ $C->{$C->{CL}}->{r_LS1}||'(?!)' }) ) @@ -329,10 +206,6 @@ $c = $c * $C->{$C->{GL}}->{chars} + unpack ('C', $_) - $m; } 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; ## GR graphic character } elsif ($gr) { my $c = 0; @@ -341,6 +214,10 @@ $c = $c * $C->{$C->{GR}}->{chars} + unpack ('C', $_) - $m; } chr ($C->{$C->{GR}}->{ucs} + $c); + ## Control, SP, or broken data + ## TODO: support control sets other than ISO/IEC 6429's + } elsif (defined $misc) { + $misc; ## Graphic character with SS2 } elsif ($ss2) { $ss2 =~ tr/\x80-\xFF/\x00-\x7F/; @@ -359,8 +236,7 @@ chr ($C->{G3}->{ucs} + $c); ## Escape sequence } elsif ($esc) { - ## IRR (revision number) - if ($esc =~ /\x1B\x26([\x40-\x7E])/) { + if ($esc =~ /\x1B\x26([\x40-\x7E])/) { ## 6F (IRR) = ESC 02/06 Ft $C->{_irr} = $1; $esc = ''; } else { $esc =~ s{ @@ -384,47 +260,54 @@ $CZD, $C1D, $Fs, $sI, $sF,$ACS) = ($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15); my $rev = $C->{_irr} || ''; - if ($g94_g) { - $C->{ $_GB_to_GN{ $g94_g } } = $CHARSET{G94}->{ $g94_f.$rev } - || $CHARSET{G94}->{ $g94_f } - || $CHARSET{G94}->{ "\x7E" }; ''; - } elsif (defined $g94n_f) { - $C->{ $_GB_to_GN{ $g94n_g } || 'G0' } = $CHARSET{G94n}->{ $g94n_f.$rev } - || $CHARSET{G94n}->{ $g94n_f } - || $CHARSET{G94n}->{ "\x7E" }; ''; - } elsif ($g96_g) { - $C->{ $_GB_to_GN{ $g96_g } } = $CHARSET{G96}->{ $g96_f.$rev } - || $CHARSET{G96}->{ $g96_f } - || $CHARSET{G96}->{ "\x7E" }; ''; - } elsif (defined $g96n_f) { - $C->{ $_GB_to_GN{ $g96n_g } } = $CHARSET{G96n}->{ $g96n_f.$rev } - || $CHARSET{G96n}->{ $g96n_f } - || $CHARSET{G96n}->{ "\x7E" }; ''; - } elsif ($Fe) { ## ESC Fe => C1 + my $f2s = $C->{option}->{final_to_set}; + if ($g94_g) { ## ESC 02/08 [I] F + $C->{ $_GB_to_GN{ $g94_g } } + = $CHARSET{G94}->{ $f2s->{G94}->{$g94_f.$rev} || $g94_f.$rev } + || $CHARSET{G94}->{ $f2s->{G94}->{$g94_f} || $g94_f } + || $CHARSET{G94}->{ "\x7E" }; ''; + } elsif (defined $g94n_f) { ## ESC 02/04 [02/08..11] [I] F + $C->{ $_GB_to_GN{ $g94n_g } || 'G0' } + = $CHARSET{G94n}->{ $f2s->{G94n}->{$g94n_f.$rev} || $g94n_f.$rev } + || $CHARSET{G94n}->{ $f2s->{G94n}->{$g94n_f} || $g94n_f } + || $CHARSET{G94n}->{ "\x7E" }; ''; + } elsif ($g96_g) { ## ESC 02/12..15 [I] F + $C->{ $_GB_to_GN{ $g96_g } } + = $CHARSET{G96}->{ $f2s->{G96}->{$g96_f.$rev} || $g96_f.$rev } + || $CHARSET{G96}->{ $f2s->{G96}->{$g96_f} || $g96_f } + || $CHARSET{G96}->{ "\x7E" }; ''; + } elsif ($g96n_g) { ## ESC 02/04 02/12..15 [I] F + $C->{ $_GB_to_GN{ $g96n_g } } + = $CHARSET{G96n}->{ $f2s->{G96n}->{$g96n_f.$rev} || $g96n_f.$rev } + || $CHARSET{G96n}->{ $f2s->{G96n}->{$g96n_f} || $g96n_f } + || $CHARSET{G96n}->{ "\x7E" }; ''; + } elsif ($Fe) { ## ESC Fe = C1 chr ($C->{ $C->{ESC_Fe} }->{ucs} + (ord ($Fe) - 0x40)); - } elsif ($CZD) { - $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) { + } elsif (defined $Fs) { ## ESC Fs if ($Fs eq "\x6E") { ## LS2 $C->{GL} = 'G2'; ''; } elsif ($Fs eq "\x6F") { ## LS3 $C->{GL} = 'G3'; ''; - } elsif ($Fs eq "\x7E") { ## LS1R + } elsif ($Fs eq "\x7E" || $Fs eq "\x6B") { ## LS1R $C->{GR} = 'G1'; $C->{GL} = 'G1' if $C->{bit} == 7; ''; - } elsif ($Fs eq "\x7D") { ## LS2R + } elsif ($Fs eq "\x7D" || $Fs eq "\x6C") { ## LS2R $C->{GR} = 'G2'; $C->{GL} = 'G2' if $C->{bit} == 7; ''; - } elsif ($Fs eq "\x7C") { ## LS3R + } elsif ($Fs eq "\x7C" || $Fs eq "\x6D") { ## LS3R $C->{GR} = 'G3'; $C->{GL} = 'G3' if $C->{bit} == 7; ''; } else { chr ($CHARSET{single_control}->{Fs}->{ucs} + (ord ($Fs) - 0x60)); } - } elsif ($sI) { + } elsif (defined $CZD) { ## 1F (CZD) = ESC 02/01 [I] F + $C->{C0} = $CHARSET{C0}->{ $f2s->{C0}->{$CZD.$rev} || $CZD.$rev } + || $CHARSET{C0}->{ $f2s->{C0}->{$CZD} || $CZD } + || $CHARSET{C0}->{ "\x7E" }; ''; + } elsif (defined $C1D) { ## 2F (C1D) = ESC 02/02 [I] F + $C->{C1} = $CHARSET{C1}->{ $f2s->{C1}->{$C1D.$rev} || $C1D.$rev } + || $CHARSET{C1}->{ $f2s->{C1}->{$C1D} || $C1D } + || $CHARSET{C1}->{ "\x7E" }; ''; + } elsif ($sI) { ## 3F = ESC 02/03 [I] F chr ($CHARSET{single_control}->{'3F'.$sI}->{ucs} + (ord ($sF) - 0x30)); - } elsif ($ACS) { ## Announcer + } elsif ($ACS) { ## 0F (Announcer) = ESC 02/00 F if ($ACS eq "\x4A") { $C->{bit} = 7 } elsif ($ACS eq "\x4B") { $C->{bit} = 8 } ''; @@ -433,35 +316,35 @@ $C->{_irr} = undef; } $esc; - ## Locking shifts - } elsif ($ls) { + } elsif ($ls) { ## Locking shifts = LS0 / LS1 if ($ls eq $C->{$C->{CL}}->{LS0}) { $C->{GL} = 'G0'; ''; } elsif ($ls eq $C->{$C->{CL}}->{LS1}) { $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}; ''; } - ## Control sequence - } elsif ($csi) { + } elsif ($csi) { ## Control sequence = CSI [P..] [I] F $csi =~ tr/\xA0-\xFF/\x20-\x7F/d; $csi =~ s/$C->{$C->{CL}}->{LS0}//g if $C->{$C->{CL}}->{LS0}; $csi =~ s/$C->{$C->{CL}}->{LS1}//g if $C->{$C->{CL}}->{LS1}; "\x9B".$csi; } - }gex; + }gesx; $s; -} +} # __iso2022_to_internal -sub internal_to_iso2022 ($\%) { + }; + &__iso2022_to_internal (@_) if defined $_[0]; + +} # _iso2022_to_internal + +sub internal_to_iso2022 ($;%) { my ($s, $C) = @_; $C ||= &new_object; my $r = ''; - for my $c (split //, $s) { - my $cc = ord $c; + my @c = split //, $s; + for my $i (0..$#c) { + my $c = $c[$i]; my $cc = ord $c; Encode::_utf8_off ($c); my $t; if ($cc <= 0x1F) { $t = _i2c ($c, $C, type => 'C0', charset => '@'); @@ -470,27 +353,27 @@ } elsif ($cc < 0x7F) { $t = _i2g ($c, $C, type => 'G94', charset => 'B'); } elsif ($cc <= 0x9F) { - $t = _i2c ($c, $C, type => 'C1', charset_id => '64291991C1', - charset => $C->{private_set}->{XC1}->{'64291991C1'}); + $t = _i2c (pack ('C', $cc), $C, type => 'C1', charset_id => '64291991C1', + charset => $C->{option}->{private_set}->{XC1}->{'64291991C1'}); } elsif ($cc <= 0xFF) { - $t = _i2g (chr($cc-0x80), $C, type => 'G96', charset => 'A'); + $t = _i2g (pack ('C', $cc-0x80), $C, type => 'G96', charset => 'A'); } elsif ($cc <= 0x24FF) { my $c = $cc - 0x100; - my $final = $C->{private_set}->{U96n}->[0]; + my $final = $C->{option}->{private_set}->{U96n}->[0]; if (length $final) { $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C, type => 'G96n', charset => $final); } } elsif ($cc <= 0x33FF) { my $c = $cc - 0x2500; - my $final = $C->{private_set}->{U96n}->[1]; + my $final = $C->{option}->{private_set}->{U96n}->[1]; if (length $final) { $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C, type => 'G96n', charset => $final); } } elsif (0xE000 <= $cc && $cc <= 0xFFFF) { my $c = $cc - 0xE000; - my $final = $C->{private_set}->{U96n}->[2]; + my $final = $C->{option}->{private_set}->{U96n}->[2]; if (length $final) { $t = _i2g (chr(($c / 96)+0x20).chr(($c % 96)+0x20), $C, type => 'G96n', charset => $final); @@ -556,27 +439,74 @@ } elsif (0x70400000 <= $cc && $cc <= 0x7040FFED) { my $c = $cc - 0x70400000; $t = _i2g (chr(($c % 94)+0x21), $C, charset_id => 'P'.int ($c / 94), - type => 'G94', charset => $C->{private_set}->{G94}->[ $c / 94 ]); + type => 'G94', charset => $C->{option}->{private_set}->{G94}->[ $c / 94 ]); } elsif (0x70410000 <= $cc && $cc <= 0x7041FFBF) { my $c = $cc - 0x70410000; $t = _i2g (chr(($c % 96)+0x20), $C, charset_id => 'P'.int ($c / 96), - type => 'G96', charset => $C->{private_set}->{G96}->[ $c / 96 ]); + type => 'G96', charset => $C->{option}->{private_set}->{G96}->[ $c / 96 ]); } elsif (0x70420000 <= $cc && $cc <= 0x7046F19B) { my $c = $cc % 0x10000; $t = _i2g (chr((($c % 8836) / 94)+0x21).chr(($c % 94)+0x21), $C, type => 'G94n', charset_id => 'P'.int(($cc / 0x10000) - 0x7042).'_'.int($c / 8836), - charset => $C->{private_set}->{G94n}->[ ($cc / 0x10000) - 0x7042 ] - ->[ $c / 8836 ]); + charset => $C->{option}->{private_set}->{G94n} + ->[ ($cc / 0x10000) - 0x7042 ]->[ $c / 8836 ]); } if (defined $t) { + ## Back to ISO/IEC 2022 if necessary + $t = _i2o ($t, $C, cs_F => "\x40") + if $C->{coding_system} ne $CODING_SYSTEM{"\x40"}; + } else { + ## Output in UCS-n or UTF-n if character can't be represented in ISO/IEC 2022 + my $F; my @F = qw~G /G /H /I B /A /D /F~; + push @F, qw~/J /K /L~ if $cc <= 0x10FFFF; + push @F, qw~/@ /C /E~ if $cc <= 0xFFFF; + for (@F) { + if (defined $C->{option}->{designate_to}->{coding_system}->{$_} + && $C->{option}->{designate_to}->{coding_system}->{$_} > -1) { + $F = $_; last; + } elsif ($C->{option}->{designate_to}->{coding_system}->{default} > -1) { + $F = $_; last; + } + } + $t = _i2o ($c, $C, cs_F => $F) if $F; + } + if (defined $t) { ## Output the character itself $r .= $t; + } elsif ($C->{option}->{fallback_from_ucs} =~ /quiet/) { + $r .= _back2ascii ($C) if $C->{option}->{fallback_from_ucs} =~ /back/; + return ($r, halfway => 1, converted_length => $i, + warn => $C->{option}->{fallback_from_ucs} =~ /warn/ ? 1 : 0, + reason => sprintf (q(U+%04X: There is no character mapped to), $cc)); + } elsif ($C->{option}->{fallback_from_ucs} eq 'croak') { + return ($r, halfway => 1, die => 1, + reason => sprintf (q(U+%04X: There is no character mapped to), $cc)); } else { - $r .= _i2g ($C->{option}->{undef_char}->[0], $C, - %{ $C->{option}->{undef_char}->[1] }); + ## Try to output with fallback escape sequence (if specified) + my $t = Encode::Charset->fallback_escape ($C, $c); + if (defined $t) { + my %D = (fallback => $C->{option}->{fallback_from_ucs}, reset => $C->{option}->{reset}); + $C->{option}->{fallback_from_ucs} = 'croak'; + $C->{option}->{reset} = {Gdesignation => 0, Ginvoke => 0}; + eval q{$t = $C->{_encoder}->_encode_internal ($t, $C)} or undef $t; + $C->{option}->{fallback_from_ucs} = $D{fallback}; + $C->{option}->{reset} = $D{reset}; + } + if (defined $t) { + $r .= $t; + } else { ## Replacement character specified in charset definition + unless ($C->{option}->{undef_char}->[0] eq "\x20") { ## A graphic character + $t = _i2g ($C->{option}->{undef_char}->[0], $C, + %{ $C->{option}->{undef_char}->[1] }); + } else { ## SPACE + $t = _back2ascii ($C) . "\x20"; + } + $r .= $C->{coding_system} eq $CODING_SYSTEM{"\x40"} ? + $t : _i2o ($t, $C, cs_F => "\x40"); + } } } - $r . _back2ascii ($C); + ($r . _back2ascii ($C)); ## Back to ASCII at the end of document if specified } ## $O{charset} eq undef means that charset is same as the current designated one. @@ -619,7 +549,7 @@ } $r .= _back2ascii ($C, reset_all => $C->{C1}->{reset_all}->{$s}); unless ($C->{option}->{C1invoke_to_right}) { ## ESC Fe - $s =~ s/([\x80-\x9F])/"\x1B" . chr (ord ($1) - 0x40)/ge; + $s =~ s/([\x80-\x9F])/"\x1B" . pack ('C', ord ($1) - 0x40)/ge; } return $r . $s; } @@ -729,19 +659,61 @@ } ''; } - -sub make_charset (%) { -## TODO: support private charset ID such as 'X0' - my %set = @_; - my $setid = qq($set{I}$set{F}$set{revision}); - my $settype = $set{type} || 'G94'; - delete $set{type}, $set{I}, $set{F}, $set{revision}; - $CHARSET{ $settype }->{ $setid } = \%set; +sub _i2o ($\%%) { + my ($s, $C, %O) = @_; + my $CS = $CODING_SYSTEM{ $O{cs_F} } || $CODING_SYSTEM{ $O{cs_id} } || return undef; + my $r = ''; + if ($CS ne $C->{coding_system}) { + my $e = ''; + $e .= "\x1B\x25"; + $e .= $O{cs_F} || $C->{option}->{private_set}->{coding_system}->{ $O{cs_id} } + || return undef; + if ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x40"} + || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x43"} + || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x45"} + || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4A"} + || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4B"} + || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x4C"}) { + $e =~ s/(.)/\x00$1/go; + } elsif ($C->{coding_system} eq $CODING_SYSTEM{"\x2F\x41"} + || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x44"} + || $C->{coding_system} eq $CODING_SYSTEM{"\x2F\x46"}) { + $e =~ s/(.)/\x00\x00\x00$1/go; + } + $r .= $e; + $C->{coding_system} = $CS; + if ($CS->{reset_state}) { + $C->{GL} = undef; $C->{GR} = undef; + $C->{C0} = $CHARSET{C0}->{"\x7E"}; + $C->{C1} = $CHARSET{C1}->{"\x7E"}; + $C->{G0} = $CHARSET{G94}->{"\x7E"}; + $C->{G1} = $CHARSET{G94}->{"\x7E"}; + $C->{G2} = $CHARSET{G94}->{"\x7E"}; + $C->{G3} = $CHARSET{G94}->{"\x7E"}; + } + } + if ($CS eq $CODING_SYSTEM{"\x40"}) { + # + } elsif ($CS eq $CODING_SYSTEM{G} || $CS eq $CODING_SYSTEM{'/G'} + || $CS eq $CODING_SYSTEM{'/H'} || $CS eq $CODING_SYSTEM{'/I'}) { + Encode::_utf8_off ($s); + } elsif ($CS eq $CODING_SYSTEM{'/@'} || $CS eq $CODING_SYSTEM{'/C'} + || $CS eq $CODING_SYSTEM{'/E'}) { + $s = Encode::encode ('ucs-2be', $s); + } elsif ($CS eq $CODING_SYSTEM{'/A'} || $CS eq $CODING_SYSTEM{'/D'} + || $CS eq $CODING_SYSTEM{'/F'}) { + $s = Encode::encode ('ucs-4be', $s); + } elsif ($CS eq $CODING_SYSTEM{'/J'} || $CS eq $CODING_SYSTEM{'/K'} + || $CS eq $CODING_SYSTEM{'/L'}) { + $s = Encode::encode ('UTF-16BE', $s); + } elsif ($CS eq $CODING_SYSTEM{B}) { + $s = Encode::encode ('utf-1', $s); + } else { + return undef; + } + $r . $s; } -1; -__END__ - =head1 SEE ALSO ISO/IEC 646:1991, "7-bit coded graphic character set for intormation interchange". @@ -757,7 +729,7 @@ ISO/IEC 8859, "8-Bit Single-Byte Coded Graphic Character Sets". -Encode, perlunicode +L, perlunicode =head1 TODO @@ -808,14 +780,19 @@ =back +=head1 AUTHORS + +Nanashi-san + +Wakaba + =head1 LICENSE -Copyright 2002 wakaba +Copyright 2002 AUTHORS, all rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut -# $Date: 2002/09/16 06:35:16 $ -### ISO2022.pm ends here +1; # $Date: 2002/12/18 10:21:09 $