This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Clearing up to_utf8_case() continues: this time use
[perl5.git] / ext / Encode / lib / Encode / JP / JIS.pm
CommitLineData
0e567a6c
JH
1package Encode::JP::JIS;
2use Encode::JP;
3use base 'Encode::Encoding';
4
5# Just for the time being, we implement jis-7bit
6# encoding via EUC
7
8my $canon = '7bit-jis';
9my $obj = bless {name => $canon}, __PACKAGE__;
10$obj->Define($canon);
11
12sub decode
13{
14 my ($obj,$str,$chk) = @_;
15 my $res = $str;
16 jis_euc(\$res);
17 return Encode::decode('euc-jp', $euc, $chk);
18}
19
20sub encode
21{
22 my ($obj,$str,$chk) = @_;
23 my $res = Encode::encode('euc-jp', $str, $chk);
24 euc_jis(\$res);
25 return $res;
26}
27
28use Encode::JP::Constants qw(:all);
29
30# JIS<->EUC
31
32sub jis_euc {
33 my $r_str = shift;
34 $$r_str =~ s(
35 ($RE{JIS_0212}|$RE{JIS_0208}|$RE{JIS_ASC}|$RE{JIS_KANA})
36 ([^\e]*)
37 )
38 {
39 my ($esc, $str) = ($1, $2);
40 if ($esc !~ /$RE{JIS_ASC}/o) {
41 $str =~ tr/\x21-\x7e/\xa1-\xfe/;
42 if ($esc =~ /$RE{JIS_KANA}/o) {
43 $str =~ s/([\xa1-\xdf])/\x8e$1/og;
44 }
45 elsif ($esc =~ /$RE{JIS_0212}/o) {
46 $str =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og;
47 }
48 }
49 $str;
50 }geox;
51 $$r_str;
52}
53
54sub euc_jis{
55 my $r_str = shift;
56 $$r_str =~ s{
57 ((?:$RE{EUC_C})+|(?:$RE{EUC_KANA})+|(?:$RE{EUC_0212})+)
58 }{
59 my $str = $1;
60 my $esc =
61 ( $str =~ tr/\x8E//d ) ? $ESC{KANA} :
62 ( $str =~ tr/\x8F//d ) ? $ESC{JIS_0212} :
63 $ESC{JIS_0208};
64 $str =~ tr/\xA1-\xFE/\x21-\x7E/;
65 $esc . $str . $ESC{ASC};
66 }geox;
67 $$r_str =~
68 s/\Q$ESC{ASC}\E
69 (\Q$ESC{KANA}\E|\Q$ESC{JIS_0212}\E|\Q$ESC{JIS_0208}\E)/$1/gox;
70 $$r_str;
71}
72
731;
74__END__