/[suikacvs]/test/oldencodeutils/lib/Encode/SJIS.pm

Diff of /test/oldencodeutils/lib/Encode/SJIS.pm

Parent Directory | Revision Log | View Patch Patch

-revision 1.1 by wakaba,
Sat Oct 12 07:27:01 2002 UTC
+revision 1.5 by wakaba,
Mon Dec 16 10:25:01 2002 UTC
 Line 5 
 Encode::SJIS --- Shift JIS coding system
  =head1 ENCODINGS
- This module defines only two basic version of shift JIS.
+ This module defines encoding engine for Shift JIS coding systems.
- Other variants are defined in Encode::SJIS::* modules.
+ This module only provides general en/decoding parts.  Actual profiles
+ for Shift JISes are included in Encode::SJIS::*.
  =over 4
-Line 17 
 use 5.7.3;
+Line 18 
 use 5.7.3;
  use strict;
  our $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
  require Encode::Charset;
+ use base qw(Encode::Encoding);
- ### --- Perl Encode module common functions
- sub encode ($$;$) {
-   my ($obj, $str, $chk) = @_;
-   $_[1] = '' if $chk;
-   if (!defined $obj->{_encode_mapping} || $obj->{_encode_mapping}) {
-     require Encode::Table;
-     $str = Encode::Table::convert ($str, $obj->__encode_map,
-       -autoload => defined $obj->{_encode_mapping_autoload} ?
-                    $obj->{_encode_mapping_autoload} : 1);
-   }
-   $str = &internal_to_sjis ($str, $obj->__2022_encode);
-   $str;
- }
- sub decode ($$;$) {
-   my ($obj, $str, $chk) = @_;
-   $_[1] = '' if $chk;
-   $str = &sjis_to_internal ($str, $obj->__2022_decode);
-   if (!defined $obj->{_decode_mapping} || $obj->{_decode_mapping}) {
-     require Encode::Table;
-     $str = Encode::Table::convert ($str, $obj->__decode_map,
-       -autoload => defined $obj->{_decode_mapping_autoload} ?
-                    $obj->{_decode_mapping_autoload} : 1);
-   }
-   $str;
- }
- ### --- Encode::SJIS unique functions
  *new_object = \&Encode::Charset::new_object_sjis;
+ ## Code extention escape sequence defined by ISO/IEC 2022 is
+ ## not supported in this version of this module.
  sub sjis_to_internal ($$) {
    my ($s, $C) = @_;
    $C ||= &new_object;
-Line 96 
 sub sjis_to_internal ($$) {
+Line 72 
 sub sjis_to_internal ($$) {
    $s;
  }
- sub __clone ($) {
+ sub internal_to_sjis ($\%) {
-   my $self = shift;
+   use integer;
-   bless {%$self}, ref $self;
+   my ($s, $C) = @_;
- };
+   $C ||= &new_object;
- use base qw(Encode::Encoding);
+   my $r = '';
- __PACKAGE__->Define (qw!shift_jisx0213 japanese-shift-jisx0213
+   my @c = split //, $s;
- shift-jisx0213 x-shift_jisx0213 shift-jis-3
+   for my $i (0..$#c) {
- sjis shift-jis x-sjis x_sjis x-sjis-jp shiftjis x-shiftjis
+     my $c = $c[$i]; my $cc = ord $c;  Encode::_utf8_off ($c);
- x-shift-jis shift.jis!);
+     my $t;
+     ## CL = C0 control characters
- =item sjis
+     if ($cc <= 0x1F) {
+       $t = $c if $C->{ $C->{CL} } eq $Encode::Charset::CHARSET{C0}->{"\x40"};
- "Shift JIS" coding system.  (Alias: shift-jis, shiftjis,
+     ## 0x20 == SP and 0x7E == DEL
- shift.jis, x-shiftjis, x-shift-jis, x-sjis, x_sjis,
+     } elsif ($cc == 0x20 || $cc == 0x7F) {
- x-sjis-jp)
+       $t = $c;
+     ## GL = G0 = ISO/IEC 646 graphic character set
- Since this name is ambiguous (it can now refer all or any
+     } elsif ($cc < 0x7F) {
- of shift JIS coding system family), this name should not
+       $t = $c if $C->{ $C->{GL} } eq $Encode::Charset::CHARSET{G94}->{"\x42"};
- be used to address specific coding system.  In this module,
+     ## 0x80
- this is considered as an alias name to the shift JIS with
+     } elsif ($C->{option}->{C1invoke_to_right} && $cc == 0x80) {
- latest official definition, currently of JIS X 0213:2000
+       $t = "\x80"
- Appendix 1 (with implemention level 4).
+         if $C->{ $C->{CR} } eq $Encode::Charset::CHARSET{C1}->{'64291991C1'};
+     ## ESC Fe = C1 control characters
- Note that the name "Shift_JIS" is not associated with
+     } elsif ($cc <= 0x9F) {
- this name, because IANA registry [IANAREG] assignes
+       $t = "\x1B".pack 'C', ($cc - 0x40)
- it to a shift JIS defined by JIS X 0208:1997.
+         if $C->{ $C->{ESC_Fe} } eq $Encode::Charset::CHARSET{C1}->{'64291991C1'};
+     ## G1 or G3 = 94^2 graphic character set from ISO-IR
- =item shift_jisx0213
+     } elsif (0xE9F6C0 <= $cc && $cc <= 0xF06F80) {
+       my $c = $cc - 0xE9F6C0;  my $F = chr (($c / 8836)+0x30);
- Shift_JISX0213 coded representation, defined by
+       if ($C->{G1} eq $Encode::Charset::CHARSET{G94n}->{ $F }) {
- JIS X 0213:2000 Appendix 1 (implemention level 4).
+         my ($c1, $c2) = ((($c % 8836) / 94)+0x21, ($c % 94)+0x21);
- (Alias: shift-jisx0213, x-shift_jisx0213, japanese-shift-jisx0213 (emacsen),
+         $t = pack ('CC', (($c1 - 1) >> 1) + ($c1 < 0x5F ? 0x71 : 0xB1),
- shift-jis-3 (Yudit))
+                $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E));
+       } elsif ($C->{G3} eq $Encode::Charset::CHARSET{G94n}->{ $F }) {
- =cut
+         my ($c1, $c2) = ((($c % 8836) / 94)+0x21, ($c % 94)+0x21);
+         if ($C->{G3}->{Csjis_first}) {
- sub __2022__common ($) {
+           my $fb = $C->{G3}->{Csjis_first}->{ ($c % 8836) / 94 };
-   my $C = Encode::SJIS->new_object;
+           $t = pack ('CC', $fb, $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E)) if $fb;
-   $C->{G0} = $Encode::Charset::CHARSET{G94}->{J};       ## JIS X 0201:1997 Latin
+         } else {
-   $C->{G1} = $Encode::Charset::CHARSET{G94n}->{"\x4F"}; ## JIS X 0213:2000 plane 1
+           $t = pack ('CC', ($c / 188) + 0xF0,
-   $C->{G2} = $Encode::Charset::CHARSET{G94}->{I};       ## JIS X 0201:1997 Katakana
+                      $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E))
-   $C->{G3} = $Encode::Charset::CHARSET{G94n}->{"\x50"}; ## JIS X 0213:2000 plane 2
+                if ($c / 188) + 0xF0 < 0xFD;
-   $C;
+         }
- }
+       }
- sub __2022_encode ($) {
+     ## G1 = JIS X 0208-1990/:1997
-   my $C = shift->__2022__common;
+     } elsif (0xF49D7C <= $cc && $cc <= 0xF4BFFF) {
-   $C;
+       my $c = $cc - 0xF49D7C;
- }
+       if ($C->{G1} eq $Encode::Charset::CHARSET{G94n}->{'B@'}) {
- sub __2022_decode ($) {
+         my ($c1, $c2) = ((($c % 8836) / 94)+0x21, ($c % 94)+0x21);
-   my $C = shift->__2022__common;
+         $t = pack ('CC', (($c1 - 1) >> 1) + ($c1 < 0x5F ? 0x71 : 0xB1),
-   $C;
+                $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E));
- }
+       }
- sub __encode_map ($) {
+     ## GL = G0 = ISO/IEC 646 graphic character set / GR = G2 = JIS X 0201 Katakana set
-   [qw/ucs_to_jisx0201_latin ucs_to_jisx0213_2000_1 ucs_to_jisx0213_2000_2 ucs_to_jisx0201_katakana/];
+     } elsif (0xE90940 <= $cc && $cc <= 0xE92641) {
- }
+       my $c = $cc - 0xE90940;  my $F = chr (($c / 94)+0x30);
- sub __decode_map ($) {
+       if ($C->{ $C->{GL} } eq $Encode::Charset::CHARSET{G94}->{ $F }) {
-   [qw/jisx0201_latin_to_ucs jisx0213_2000_1_to_ucs jisx0213_2000_2_to_ucs jisx0201_katakana_to_ucs/];
+         $t = pack 'C', (($c % 94) + 0x21);
- }
+       } elsif ($C->{ $C->{GR} } eq $Encode::Charset::CHARSET{G94}->{ $F }) {
+         $t = pack 'C', (($c % 94) + 0xA1) if ($c % 94) < 0x3F;
- package Encode::SJIS::X0213ASCII;
+       }
- use vars qw/@ISA/;
+     ## G1 / G3 = 94^2 graphic character set
- push @ISA, 'Encode::SJIS';
+     } elsif (0x70420000 <= $cc && $cc <= 0x7046F19B) {
- __PACKAGE__->Define (qw/shift_jisx0213-ascii sjis-ascii shift-jis-ascii/);
+       my $c = $cc % 0x10000;
+       my $F0=$C->{option}->{private_set}->{G94n}->[($cc/0x10000)-0x7042]->[$c/8836];
- =item sjis-ascii
+       my $F1 = 'P'.(($cc / 0x10000) - 0x7042).'_'.($c / 8836);
+       if ($C->{G3} eq $Encode::Charset::CHARSET{G94n}->{ $F0 }
- Same as sjis but ASCII (ISO/IEC 646 IRV) instead of
+        || $C->{G3} eq $Encode::Charset::CHARSET{G94n}->{ $F1 }) {
- JIS X 0201 Roman (or Latin) set.  (Alias: shift-jis-ascii)
+         my ($c1, $c2) = ((($c % 8836) / 94)+0x21, ($c % 94)+0x21);
+         if ($C->{G3}->{Csjis_first}) {
- In spite of the history of shift JIS, ASCII is sometimes
+           my $fb = $C->{G3}->{Csjis_first}->{ ($c % 8836) / 94 };
- used instead of JIS X 0201 Roman set, because of compatibility
+           $t = pack ('CC', $fb, $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E)) if $fb;
- with ASCII world.
+         } else {
+           $t = pack ('CC', ($c / 188) + 0xF0,
- Note that this name is now an alias of shift_jisx0213-ascii,
+                      $c2 + (($c1 & 1) ? ($c2 < 0x60 ? 0x1F : 0x20) : 0x7E))
- as sjis is of shift_jisx0213.
+                if ($c / 188) + 0xF0 < 0xFD;
+         }
- =item shift_jisx0213-ascii
+       }
+     ## Other character sets are not supported now (and there is no plan to implement them).
- Same as Shift_JISX0213 but ASCII (ISO/IEC 646 IRV)
+     }
- instead of JIS X 0201:1997 Latin character set.
+     ## Output the character itself
- =cut
+     if (defined $t) {
+       $r .= $t;
- sub __2022__common ($) {
+     ## Output the character itself with mapping table of special code positions
-   my $C = shift->SUPER::__2022__common;
+     } elsif ($C->{GsmapR}->{ $c }) {
-   $C->{G0} = $Encode::Charset::CHARSET{G94}->{B};       ## ASCII
+       $r .= $C->{GsmapR}->{ $c };
-   $C;
+     } elsif ($C->{option}->{fallback_from_ucs} =~ /quiet/) {
- }
+       return ($r, halfway => 1, converted_length => $i,
- sub __encode_map ($) {
+               warn => $C->{option}->{fallback_from_ucs} =~ /warn/ ? 1 : 0,
-   [qw/ucs_to_ascii ucs_to_jisx0213_2000_1 ucs_to_jisx0213_2000_2 ucs_to_jisx0201_katakana/];
+               reason => sprintf (q(U+%04X: There is no character mapped to), $cc));
- }
+     } elsif ($C->{option}->{fallback_from_ucs} eq 'croak') {
- sub __decode_map ($) {
+       return ($r, halfway => 1, die => 1,
-   [qw/jisx0213_2000_1_to_ucs jisx0213_2000_2_to_ucs jisx0201_katakana_to_ucs/];
+               reason => sprintf (q(U+%04X: There is no character mapped to), $cc));
+     ##
+     } else {
+       ## 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
+         $r .= $C->{option}->{undef_char_sjis} || "\x3F";
+       }
+     }
+   }
+   $r;
  }
-;
+ =back
- __END__
  =head1 SEE ALSO
-Line 205 
 JIS X 0213:2000, "7-bit and 8-bit double
+Line 200 
 JIS X 0213:2000, "7-bit and 8-bit double
  sets for information interchange", Japan Industrial Standards
  Committee (JISC) <http://www.jisc.go.jp/>, 2000.
- Encode, perlunicode
+ L<Encode::SJIS::JIS>
+ L<Encode>, L<perlunicode>
- [IANAREG] "CHARACTER SETS", IANA <http://www.iana.org/>,
+ L<Encode::Charset>, L<Encode::ISO2022>
- <http://www.iana.org/assignments/character-sets>.
- The charset registry for IETF <http://www.ietf.org/> standards.
- (Note that in this registry two shift JISes are registered,
- "Shift_JIS" and "Windows-31j".  Former is JIS X 0208:1997's
- definition and later is the Windows standard character set.)
  =head1 LICENSE
- Copyright 2002 Nanashi-san
+ Copyright 2002 Nanashi-san <[email protected]>
  This library is free software; you can redistribute it
  and/or modify it under the same terms as Perl itself.
  =cut
- # $Date$
+; # $Date$
- ### SJIS.pm ends here

 Legend:



Removed from v.1.1
 


changed lines


 
Added in v.1.5
 Legend:



Removed from v.1.1
 


changed lines


 
Added in v.1.5
-Removed from v.1.1
+Added in v.1.5

[email protected]	ViewVC Help
Powered by ViewVC 1.1.24