/[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.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 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};  
 }  
   
   
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 262  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 570  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 ($C->{option}->{undef_char}->[0], $C,        $t = _i2g ($C->{option}->{undef_char}->[0], $C,
497                    %{ $C->{option}->{undef_char}->[1] });                    %{ $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 729  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 808  not implemented yet. Line 776  not implemented yet.
776    
777  =back  =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.4  
changed lines
  Added in v.1.5
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24