/[suikacvs]/perl/lib/Encode/SJIS.pm
Suika

Diff of /perl/lib/Encode/SJIS.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by wakaba, Sat Oct 12 07:27:01 2002 UTC revision 1.2 by wakaba, Sat Oct 12 11:03:00 2002 UTC
# Line 17  use 5.7.3; Line 17  use 5.7.3;
17  use strict;  use strict;
18  our $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  our $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
19  require Encode::Charset;  require Encode::Charset;
20    use base qw(Encode::Encoding);
21    
22  ### --- Perl Encode module common functions  ### --- Perl Encode module common functions
23    
# Line 96  sub sjis_to_internal ($$) { Line 97  sub sjis_to_internal ($$) {
97    $s;    $s;
98  }  }
99    
100    sub internal_to_sjis ($\%) {
101      use integer;
102      my ($s, $C) = @_;
103      $C ||= &new_object;
104      
105      my $r = '';
106      for my $c (split //, $s) {
107        my $cc = ord $c;
108        my $t;
109        if ($cc <= 0x1F) {
110          $t = $c if $C->{ $C->{CL} } eq $Encode::Charset::CHARSET{C0}->{"\x40"};
111        } elsif ($cc == 0x20 || $cc == 0x7F) {
112          $t = $c;
113        } elsif ($cc < 0x7F) {
114          $t = $c if $C->{ $C->{GL} } eq $Encode::Charset::CHARSET{G94}->{"\x42"};
115        } elsif ($C->{option}->{C1invoke_to_right} && $cc == 0x80) {
116          $t = $c if $C->{ $C->{CR} } eq $Encode::Charset::CHARSET{C1}->{'64291991C1'};
117        } elsif ($cc <= 0x9F) {
118          $t = "\x1B".chr ($cc - 0x40)
119            if $C->{ $C->{ESC_Fe} } eq $Encode::Charset::CHARSET{C1}->{'64291991C1'};
120        
121        } elsif (0xE9F6C0 <= $cc && $cc <= 0xF06F80) {
122          my $c = $cc - 0xE9F6C0;  my $F = chr (($c / 8836)+0x30);
123          if ($C->{G1} eq $Encode::Charset::CHARSET{G94n}->{ $F }) {
124            my ($c1, $c2) = ((($c % 8836) / 94)+0x21, ($c % 94)+0x21);
125            $t = pack ('CC', (($c1 - 1) >> 1) + ($c1 < 0x5F ? 0x71 : 0xB1),
126                   $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E));
127          } elsif ($C->{G3} eq $Encode::Charset::CHARSET{G94n}->{ $F }) {
128            my ($c1, $c2) = ((($c % 8836) / 94)+0x21, ($c % 94)+0x21);
129            if ($C->{G3}->{Csjis_first}) {
130              $t = pack ('CC', $C->{G3}->{Csjis_first}->{ ($c % 8836) / 94 },
131                         $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E));
132            } else {
133              $t = pack ('CC', ($c / 188) + 0xF0,
134                         $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E))
135                   if ($c / 188) + 0xF0 < 0xFD;
136            }
137          }
138        } elsif (0xF49D7C <= $cc && $cc <= 0xF4BFFF) {
139          my $c = $cc - 0xF49D7C;
140          if ($C->{G1} eq $Encode::Charset::CHARSET{G94n}->{'B@'}) {
141            my ($c1, $c2) = ((($c % 8836) / 94)+0x21, ($c % 94)+0x21);
142            $t = pack ('CC', (($c1 - 1) >> 1) + ($c1 < 0x5F ? 0x71 : 0xB1),
143                   $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E));
144          }
145        
146        } elsif (0xE90940 <= $cc && $cc <= 0xE92641) {
147          my $c = $cc - 0xE90940;  my $F = chr (($c / 94)+0x30);
148          if ($C->{ $C->{GL} } eq $Encode::Charset::CHARSET{G94}->{ $F }) {
149            $t = chr (($c % 94) + 0x21);
150          } elsif ($C->{ $C->{GR} } eq $Encode::Charset::CHARSET{G94}->{ $F }) {
151            $t = chr (($c % 94) + 0xA1) if ($c % 94) < 0x3F;
152          }
153        } elsif (0x70420000 <= $cc && $cc <= 0x7046F19B) {
154          my $c = $cc % 0x10000;
155          my $F0=$C->{option}->{private_set}->{G94n}->[($cc/0x10000)-0x7042]->[$c/8836];
156          my $F1 = 'P'.(($cc / 0x10000) - 0x7042).'_'.($c / 8836);
157          if ($C->{G3} eq $Encode::Charset::CHARSET{G94n}->{ $F0 }
158           || $C->{G3} eq $Encode::Charset::CHARSET{G94n}->{ $F1 }) {
159            my ($c1, $c2) = ((($c % 8836) / 94)+0x21, ($c % 94)+0x21);
160            if ($C->{G3}->{Csjis_first}) {
161              $t = pack ('CC', $C->{G3}->{Csjis_first}->{ ($c % 8836) / 94 },
162                         $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E));
163            } else {
164              $t = pack ('CC', ($c / 188) + 0xF0,
165                         $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E))
166                   if ($c / 188) + 0xF0 < 0xFD;
167            }
168          }
169        }
170        
171        if (defined $t) {
172          $r .= $t;
173        } elsif ($C->{GsmapR}->{ $c }) {
174          $r .= $C->{GsmapR}->{ $c };
175        } else {
176          $r .= $C->{option}->{undef_char_sjis} || "\x3F";
177        }
178      }
179      $r;
180    }
181    
182  sub __clone ($) {  sub __clone ($) {
183    my $self = shift;    my $self = shift;
184    bless {%$self}, ref $self;    bless {%$self}, ref $self;
185  };  };
186    
 use base qw(Encode::Encoding);  
187  __PACKAGE__->Define (qw!shift_jisx0213 japanese-shift-jisx0213  __PACKAGE__->Define (qw!shift_jisx0213 japanese-shift-jisx0213
188  shift-jisx0213 x-shift_jisx0213 shift-jis-3  shift-jisx0213 x-shift_jisx0213 shift-jis-3 shift-jis-2000
189  sjis shift-jis x-sjis x_sjis x-sjis-jp shiftjis x-shiftjis  sjis shift-jis x-sjis x_sjis x-sjis-jp shiftjis x-shiftjis
190  x-shift-jis shift.jis!);  x-shift-jis shift.jis!);
191    
# Line 129  it to a shift JIS defined by JIS X 0208: Line 211  it to a shift JIS defined by JIS X 0208:
211  Shift_JISX0213 coded representation, defined by  Shift_JISX0213 coded representation, defined by
212  JIS X 0213:2000 Appendix 1 (implemention level 4).  JIS X 0213:2000 Appendix 1 (implemention level 4).
213  (Alias: shift-jisx0213, x-shift_jisx0213, japanese-shift-jisx0213 (emacsen),  (Alias: shift-jisx0213, x-shift_jisx0213, japanese-shift-jisx0213 (emacsen),
214  shift-jis-3 (Yudit))  shift-jis-3 (Yudit), shift-jis-2000)
215    
216  =cut  =cut
217    
# Line 159  sub __decode_map ($) { Line 241  sub __decode_map ($) {
241  package Encode::SJIS::X0213ASCII;  package Encode::SJIS::X0213ASCII;
242  use vars qw/@ISA/;  use vars qw/@ISA/;
243  push @ISA, 'Encode::SJIS';  push @ISA, 'Encode::SJIS';
244  __PACKAGE__->Define (qw/shift_jisx0213-ascii sjis-ascii shift-jis-ascii/);  __PACKAGE__->Define (qw/shift_jisx0213-ascii shift-jis-2000-ascii
245    sjis-ascii shift-jis-ascii/);
246    
247  =item sjis-ascii  =item sjis-ascii
248    
# Line 177  as sjis is of shift_jisx0213. Line 260  as sjis is of shift_jisx0213.
260    
261  Same as Shift_JISX0213 but ASCII (ISO/IEC 646 IRV)  Same as Shift_JISX0213 but ASCII (ISO/IEC 646 IRV)
262  instead of JIS X 0201:1997 Latin character set.  instead of JIS X 0201:1997 Latin character set.
263    (Alias: shift-jis-2000-ascii)
264    
265    Note that this coding system does NOT comform to
266    JIS X 0213:2000 Appendix 1.
267    
268  =cut  =cut
269    
# Line 195  sub __decode_map ($) { Line 282  sub __decode_map ($) {
282  1;  1;
283  __END__  __END__
284    
285    =back
286    
287  =head1 SEE ALSO  =head1 SEE ALSO
288    
289  JIS X 0208:1997, "7-bit and 8-bit double byte coded Kanji  JIS X 0208:1997, "7-bit and 8-bit double byte coded Kanji
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24