lib/Encode/SJIS.pm


=head1 NAME

Encode::SJIS --- Shift JIS coding systems encoder and decoder

=head1 ENCODINGS

This module defines only two basic version of shift JIS.
Other variants are defined in Encode::SJIS::* modules.

=over 4

=cut

package Encode::SJIS;
use 5.7.3;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Encode::Charset;

### --- 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;

sub sjis_to_internal ($$) {
  my ($s, $C) = @_;
  $C ||= &new_object;
  $s =~ s{
     ([\x00-\x7F\xA1-\xDF])
  #   ([\xA1-\xDF])
    |([\x81-\x9F\xE0-\xFC][\x40-\x7E\x80-\xFC])
    |\x1B([\x40-\x5F])
    |([\x80-\xFF])      ## Broken or supplemental 1-byte character
  }{
    my ($c7, $c2, $c1, $c8) = ($1, $2, $3, $4);
    if (defined $c7) {
      if ($c7 =~ /([\x21-\x7E])/) {
        chr ($C->{ $C->{GL} }->{ucs} + ord ($1) - 0x21);
      } elsif ($c7 =~ /([\x00-\x1F])/) {
        chr ($C->{ $C->{CL} }->{ucs} + ord ($1));
      } elsif ($C->{GR} && $c7 =~ /([\xA1-\xDF])/) {
        chr ($C->{ $C->{GR} }->{ucs} + ord ($1) - 0xA1);
      } else {  ## 0x20, 0x7F
        $C->{Gsmap}->{ $c7 } || $c7;
      }
    } elsif ($c2) {
      if ($c2 =~ /([\x81-\xEF])(.)/) {
        my ($f, $s) = (ord $1, ord $2);
        $f -= $f < 0xA0 ? 0x81 : 0xC1;  $s -= 0x40 + ($s > 0x7F);
        chr ($C->{G1}->{ucs} + $f * 188 + $s);
      } else {  ## [\xF0-\xFC].
        my ($f, $s) = unpack ('CC', $c2);
        if ($C->{G3}->{Csjis_kuE}) {
          $f = $s > 0x9E ? $C->{G3}->{Csjis_kuE}->{ $f }:
                           $C->{G3}->{Csjis_kuO}->{ $f };
          $s -= ($s > 0x9E ? 0x9F : $s > 0x7F ? 0x41 : 0x40);
          chr ($C->{G3}->{ucs} + $f * 94 + $s);
        } else {
          $f -= 0xF0; $s -= 0x40 + ($s > 0x7F);
          chr ($C->{G3}->{ucs} + $f * 188 + $s);
        }
      }
    } elsif ($c1) {     ## ESC Fe
      chr ($C->{ $C->{ESC_Fe} }->{ucs} + ord ($c1) - 0x40);
    } else {    # $C8
      $C->{Gsmap}->{ $c8 } || $c8;
    }
  }gex;
  $s;
}

sub __clone ($) {
  my $self = shift;
  bless {%$self}, ref $self;
};

use base qw(Encode::Encoding);
__PACKAGE__->Define (qw!shift_jisx0213 japanese-shift-jisx0213
shift-jisx0213 x-shift_jisx0213 shift-jis-3
sjis shift-jis x-sjis x_sjis x-sjis-jp shiftjis x-shiftjis
x-shift-jis shift.jis!);

=item sjis

"Shift JIS" coding system.  (Alias: shift-jis, shiftjis,
shift.jis, x-shiftjis, x-shift-jis, x-sjis, x_sjis,
x-sjis-jp)

Since this name is ambiguous (it can now refer all or any
of shift JIS coding system family), this name should not
be used to address specific coding system.  In this module,
this is considered as an alias name to the shift JIS with
latest official definition, currently of JIS X 0213:2000
Appendix 1 (with implemention level 4).

Note that the name "Shift_JIS" is not associated with
this name, because IANA registry [IANAREG] assignes
it to a shift JIS defined by JIS X 0208:1997.

=item shift_jisx0213

Shift_JISX0213 coded representation, defined by
JIS X 0213:2000 Appendix 1 (implemention level 4).
(Alias: shift-jisx0213, x-shift_jisx0213, japanese-shift-jisx0213 (emacsen),
shift-jis-3 (Yudit))

=cut

sub __2022__common ($) {
  my $C = Encode::SJIS->new_object;
  $C->{G0} = $Encode::Charset::CHARSET{G94}->{J};       ## JIS X 0201:1997 Latin
  $C->{G1} = $Encode::Charset::CHARSET{G94n}->{"\x4F"}; ## JIS X 0213:2000 plane 1
  $C->{G2} = $Encode::Charset::CHARSET{G94}->{I};       ## JIS X 0201:1997 Katakana
  $C->{G3} = $Encode::Charset::CHARSET{G94n}->{"\x50"}; ## JIS X 0213:2000 plane 2
  $C;
}
sub __2022_encode ($) {
  my $C = shift->__2022__common;
  $C;
}
sub __2022_decode ($) {
  my $C = shift->__2022__common;
  $C;
}
sub __encode_map ($) {
  [qw/ucs_to_jisx0201_latin ucs_to_jisx0213_2000_1 ucs_to_jisx0213_2000_2 ucs_to_jisx0201_katakana/];
}
sub __decode_map ($) {
  [qw/jisx0201_latin_to_ucs jisx0213_2000_1_to_ucs jisx0213_2000_2_to_ucs jisx0201_katakana_to_ucs/];
}

package Encode::SJIS::X0213ASCII;
use vars qw/@ISA/;
push @ISA, 'Encode::SJIS';
__PACKAGE__->Define (qw/shift_jisx0213-ascii sjis-ascii shift-jis-ascii/);

=item sjis-ascii

Same as sjis but ASCII (ISO/IEC 646 IRV) instead of
JIS X 0201 Roman (or Latin) set.  (Alias: shift-jis-ascii)

In spite of the history of shift JIS, ASCII is sometimes
used instead of JIS X 0201 Roman set, because of compatibility
with ASCII world.

Note that this name is now an alias of shift_jisx0213-ascii,
as sjis is of shift_jisx0213.

=item shift_jisx0213-ascii

Same as Shift_JISX0213 but ASCII (ISO/IEC 646 IRV)
instead of JIS X 0201:1997 Latin character set.

=cut

sub __2022__common ($) {
  my $C = shift->SUPER::__2022__common;
  $C->{G0} = $Encode::Charset::CHARSET{G94}->{B};       ## ASCII
  $C;
}
sub __encode_map ($) {
  [qw/ucs_to_ascii ucs_to_jisx0213_2000_1 ucs_to_jisx0213_2000_2 ucs_to_jisx0201_katakana/];
}
sub __decode_map ($) {
  [qw/jisx0213_2000_1_to_ucs jisx0213_2000_2_to_ucs jisx0201_katakana_to_ucs/];
}

1;
__END__

=head1 SEE ALSO

JIS X 0208:1997, "7-bit and 8-bit double byte coded Kanji
set for information interchange", Japan Industrial Standards
Committee (JISC) <http://www.jisc.go.jp/>, 1997.

JIS X 0213:2000, "7-bit and 8-bit double byte coded extended Kanji
sets for information interchange", Japan Industrial Standards
Committee (JISC) <http://www.jisc.go.jp/>, 2000.

Encode, perlunicode

[IANAREG] "CHARACTER SETS", IANA <http://www.iana.org/>,
<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

This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=cut

# $Date: 2002/09/21 01:34:08 $
### SJIS.pm ends here
1
2	=head1 NAME
3
4	Encode::SJIS --- Shift JIS coding systems encoder and decoder
5
6	=head1 ENCODINGS
7
8	This module defines only two basic version of shift JIS.
9	Other variants are defined in Encode::SJIS::* modules.
10
11	=over 4
12
13	=cut
14
15	package Encode::SJIS;
16	use 5.7.3;
17	use strict;
18	our $VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
19	require Encode::Charset;
20
21	### --- Perl Encode module common functions
22
23	sub encode ($$;$) {
24	my ($obj, $str, $chk) = @_;
25	$_[1] = '' if $chk;
26	if (!defined $obj->{_encode_mapping} \|\| $obj->{_encode_mapping}) {
27	require Encode::Table;
28	$str = Encode::Table::convert ($str, $obj->__encode_map,
29	-autoload => defined $obj->{_encode_mapping_autoload} ?
30	$obj->{_encode_mapping_autoload} : 1);
31	}
32	$str = &internal_to_sjis ($str, $obj->__2022_encode);
33	$str;
34	}
35
36	sub decode ($$;$) {
37	my ($obj, $str, $chk) = @_;
38	$_[1] = '' if $chk;
39	$str = &sjis_to_internal ($str, $obj->__2022_decode);
40	if (!defined $obj->{_decode_mapping} \|\| $obj->{_decode_mapping}) {
41	require Encode::Table;
42	$str = Encode::Table::convert ($str, $obj->__decode_map,
43	-autoload => defined $obj->{_decode_mapping_autoload} ?
44	$obj->{_decode_mapping_autoload} : 1);
45	}
46	$str;
47	}
48
49	### --- Encode::SJIS unique functions
50	*new_object = \&Encode::Charset::new_object_sjis;
51
52	sub sjis_to_internal ($$) {
53	my ($s, $C) = @_;
54	$C \|\|= &new_object;
55	$s =~ s{
56	([\x00-\x7F\xA1-\xDF])
57	# ([\xA1-\xDF])
58	\|([\x81-\x9F\xE0-\xFC][\x40-\x7E\x80-\xFC])
59	\|\x1B([\x40-\x5F])
60	\|([\x80-\xFF]) ## Broken or supplemental 1-byte character
61	}{
62	my ($c7, $c2, $c1, $c8) = ($1, $2, $3, $4);
63	if (defined $c7) {
64	if ($c7 =~ /([\x21-\x7E])/) {
65	chr ($C->{ $C->{GL} }->{ucs} + ord ($1) - 0x21);
66	} elsif ($c7 =~ /([\x00-\x1F])/) {
67	chr ($C->{ $C->{CL} }->{ucs} + ord ($1));
68	} elsif ($C->{GR} && $c7 =~ /([\xA1-\xDF])/) {
69	chr ($C->{ $C->{GR} }->{ucs} + ord ($1) - 0xA1);
70	} else { ## 0x20, 0x7F
71	$C->{Gsmap}->{ $c7 } \|\| $c7;
72	}
73	} elsif ($c2) {
74	if ($c2 =~ /([\x81-\xEF])(.)/) {
75	my ($f, $s) = (ord $1, ord $2);
76	$f -= $f < 0xA0 ? 0x81 : 0xC1; $s -= 0x40 + ($s > 0x7F);
77	chr ($C->{G1}->{ucs} + $f * 188 + $s);
78	} else { ## [\xF0-\xFC].
79	my ($f, $s) = unpack ('CC', $c2);
80	if ($C->{G3}->{Csjis_kuE}) {
81	$f = $s > 0x9E ? $C->{G3}->{Csjis_kuE}->{ $f }:
82	$C->{G3}->{Csjis_kuO}->{ $f };
83	$s -= ($s > 0x9E ? 0x9F : $s > 0x7F ? 0x41 : 0x40);
84	chr ($C->{G3}->{ucs} + $f * 94 + $s);
85	} else {
86	$f -= 0xF0; $s -= 0x40 + ($s > 0x7F);
87	chr ($C->{G3}->{ucs} + $f * 188 + $s);
88	}
89	}
90	} elsif ($c1) { ## ESC Fe
91	chr ($C->{ $C->{ESC_Fe} }->{ucs} + ord ($c1) - 0x40);
92	} else { # $C8
93	$C->{Gsmap}->{ $c8 } \|\| $c8;
94	}
95	}gex;
96	$s;
97	}
98
99	sub __clone ($) {
100	my $self = shift;
101	bless {%$self}, ref $self;
102	};
103
104	use base qw(Encode::Encoding);
105	__PACKAGE__->Define (qw!shift_jisx0213 japanese-shift-jisx0213
106	shift-jisx0213 x-shift_jisx0213 shift-jis-3
107	sjis shift-jis x-sjis x_sjis x-sjis-jp shiftjis x-shiftjis
108	x-shift-jis shift.jis!);
109
110	=item sjis
111
112	"Shift JIS" coding system. (Alias: shift-jis, shiftjis,
113	shift.jis, x-shiftjis, x-shift-jis, x-sjis, x_sjis,
114	x-sjis-jp)
115
116	Since this name is ambiguous (it can now refer all or any
117	of shift JIS coding system family), this name should not
118	be used to address specific coding system. In this module,
119	this is considered as an alias name to the shift JIS with
120	latest official definition, currently of JIS X 0213:2000
121	Appendix 1 (with implemention level 4).
122
123	Note that the name "Shift_JIS" is not associated with
124	this name, because IANA registry [IANAREG] assignes
125	it to a shift JIS defined by JIS X 0208:1997.
126
127	=item shift_jisx0213
128
129	Shift_JISX0213 coded representation, defined by
130	JIS X 0213:2000 Appendix 1 (implemention level 4).
131	(Alias: shift-jisx0213, x-shift_jisx0213, japanese-shift-jisx0213 (emacsen),
132	shift-jis-3 (Yudit))
133
134	=cut
135
136	sub __2022__common ($) {
137	my $C = Encode::SJIS->new_object;
138	$C->{G0} = $Encode::Charset::CHARSET{G94}->{J}; ## JIS X 0201:1997 Latin
139	$C->{G1} = $Encode::Charset::CHARSET{G94n}->{"\x4F"}; ## JIS X 0213:2000 plane 1
140	$C->{G2} = $Encode::Charset::CHARSET{G94}->{I}; ## JIS X 0201:1997 Katakana
141	$C->{G3} = $Encode::Charset::CHARSET{G94n}->{"\x50"}; ## JIS X 0213:2000 plane 2
142	$C;
143	}
144	sub __2022_encode ($) {
145	my $C = shift->__2022__common;
146	$C;
147	}
148	sub __2022_decode ($) {
149	my $C = shift->__2022__common;
150	$C;
151	}
152	sub __encode_map ($) {
153	[qw/ucs_to_jisx0201_latin ucs_to_jisx0213_2000_1 ucs_to_jisx0213_2000_2 ucs_to_jisx0201_katakana/];
154	}
155	sub __decode_map ($) {
156	[qw/jisx0201_latin_to_ucs jisx0213_2000_1_to_ucs jisx0213_2000_2_to_ucs jisx0201_katakana_to_ucs/];
157	}
158
159	package Encode::SJIS::X0213ASCII;
160	use vars qw/@ISA/;
161	push @ISA, 'Encode::SJIS';
162	__PACKAGE__->Define (qw/shift_jisx0213-ascii sjis-ascii shift-jis-ascii/);
163
164	=item sjis-ascii
165
166	Same as sjis but ASCII (ISO/IEC 646 IRV) instead of
167	JIS X 0201 Roman (or Latin) set. (Alias: shift-jis-ascii)
168
169	In spite of the history of shift JIS, ASCII is sometimes
170	used instead of JIS X 0201 Roman set, because of compatibility
171	with ASCII world.
172
173	Note that this name is now an alias of shift_jisx0213-ascii,
174	as sjis is of shift_jisx0213.
175
176	=item shift_jisx0213-ascii
177
178	Same as Shift_JISX0213 but ASCII (ISO/IEC 646 IRV)
179	instead of JIS X 0201:1997 Latin character set.
180
181	=cut
182
183	sub __2022__common ($) {
184	my $C = shift->SUPER::__2022__common;
185	$C->{G0} = $Encode::Charset::CHARSET{G94}->{B}; ## ASCII
186	$C;
187	}
188	sub __encode_map ($) {
189	[qw/ucs_to_ascii ucs_to_jisx0213_2000_1 ucs_to_jisx0213_2000_2 ucs_to_jisx0201_katakana/];
190	}
191	sub __decode_map ($) {
192	[qw/jisx0213_2000_1_to_ucs jisx0213_2000_2_to_ucs jisx0201_katakana_to_ucs/];
193	}
194
195	1;
196	__END__
197
198	=head1 SEE ALSO
199
200	JIS X 0208:1997, "7-bit and 8-bit double byte coded Kanji
201	set for information interchange", Japan Industrial Standards
202	Committee (JISC) <http://www.jisc.go.jp/>, 1997.
203
204	JIS X 0213:2000, "7-bit and 8-bit double byte coded extended Kanji
205	sets for information interchange", Japan Industrial Standards
206	Committee (JISC) <http://www.jisc.go.jp/>, 2000.
207
208	Encode, perlunicode
209
210	[IANAREG] "CHARACTER SETS", IANA <http://www.iana.org/>,
211	<http://www.iana.org/assignments/character-sets>.
212	The charset registry for IETF <http://www.ietf.org/> standards.
213	(Note that in this registry two shift JISes are registered,
214	"Shift_JIS" and "Windows-31j". Former is JIS X 0208:1997's
215	definition and later is the Windows standard character set.)
216
217	=head1 LICENSE
218
219	Copyright 2002 Nanashi-san
220
221	This library is free software; you can redistribute it
222	and/or modify it under the same terms as Perl itself.
223
224	=cut
225
226	# $Date: 2002/09/21 01:34:08 $
227	### SJIS.pm ends here