File Coverage

blib/lib/Encode/JIS2K/2022JP3.pm
Criterion Covered Total %
statement 38 54 70.3
branch 4 22 18.1
condition 0 3 0.0
subroutine 9 10 90.0
pod n/a
total 51 89 57.3


line stmt bran cond sub pod time code
1             package Encode::JIS7::2022JP3;
2 1     1   4 use strict;
  1         2  
  1         71  
3              
4             our $VERSION = do { my @r = (q$Revision: 0.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
5              
6 1     1   4 use Encode qw(:fallbacks);
  1         2  
  1         174  
7              
8 1     1   4 use base qw(Encode::Encoding);
  1         2  
  1         143  
9              
10             my $Canon = 'iso-2022-jp-3';
11             $Encode::Encoding{$Canon} =
12             bless {
13             Name => $Canon,
14             h2z => 1,
15             jis0212 => 1,
16             } => __PACKAGE__;
17              
18             # we override this to 1 so PerlIO works
19 0     0   0 sub needs_lines { 1 }
20              
21 1     1   755 use Encode::CJKConstants qw(:all);
  1         481  
  1         571  
22              
23             our $DEBUG = 0;
24              
25             #
26             # decode is identical for all 2022 variants
27             #
28              
29             sub decode($$;$)
30             {
31 2     2   44 my ($obj, $str, $chk) = @_;
32 2         4 my $residue = '';
33 2 50       7 if ($chk){
34 0         0 $str =~ s/([^\x00-\x7f].*)$//so;
35 0 0       0 $1 and $residue = $1;
36             }
37 2         6 $residue .= jis_euc(\$str);
38 2 50       6 $_[1] = $residue if $chk;
39 2         13 return Encode::decode('euc-jisx0213', $str, FB_PERLQQ);
40             }
41              
42             #
43             # encode is different
44             #
45              
46             sub encode($$;$)
47             {
48 2     2   15870 require Encode::JP::H2Z;
49 2         1916 my ($obj, $utf8, $chk) = @_;
50             # empty the input string in the stack so perlio is ok
51 2 50       11 $_[1] = '' if $chk;
52 2         17 my ($h2z, $jis0212) = @$obj{qw(h2z jis0212)};
53 2         17 my $octet = Encode::encode('euc-jisx0213', $utf8, FB_PERLQQ) ;
54 2 50       73 $h2z and &Encode::JP::H2Z::h2z(\$octet);
55 2         59 euc_jis(\$octet, $jis0212);
56 2         12 return $octet;
57             }
58              
59              
60              
61             our $ESC_JISX0213_1 = "\e\$(O";
62             our $ESC_JISX0213_2 = "\e\$(P";
63              
64             # JIS<->EUC
65              
66             sub jis_euc {
67 2     2   5 my $r_str = shift;
68 2         61 $$r_str =~ s(
69             ($RE{JIS_0212}|$RE{JIS_0208}|$RE{ISO_ASC}|$RE{JIS_KANA})
70             ([^\e]*)
71             )
72             {
73 0         0 my ($esc, $chunk) = ($1, $2);
74 0 0       0 if ($esc !~ /$RE{ISO_ASC}/o) {
75 0         0 $chunk =~ tr/\x21-\x7e/\xa1-\xfe/;
76 0 0       0 if ($esc =~ /$RE{JIS_KANA}/o) {
    0          
77 0         0 $chunk =~ s/([\xa1-\xdf])/\x8e$1/og;
78             }
79             elsif ($esc =~ /$RE{JIS_0212}/o) {
80 0         0 $chunk =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og;
81             }
82             }
83 0         0 $chunk;
84             }geox;
85 2         7 my ($residue) = ($$r_str =~ s/(\e.*)$//so);
86 2         6 return $residue;
87             }
88              
89             sub euc_jis{
90 1     1   6 no warnings qw(uninitialized);
  1         2  
  1         283  
91 2     2   4 my $r_str = shift;
92 2         4 my $jis0212 = shift;
93 2         46 $$r_str =~ s{
94             ((?:$RE{EUC_C})+|(?:$RE{EUC_KANA})+|(?:$RE{EUC_0212})+)
95             }{
96 0         0 my $chunk = $1;
97 0 0       0 my $esc =
    0          
98             ( $chunk =~ tr/\x8E//d ) ? $ESC{KANA} :
99             ( $chunk =~ tr/\x8F//d ) ? $ESC_JISX0213_2 :
100             $ESC_JISX0213_1;
101 0 0 0     0 if ($esc eq $ESC_JISX0213_2 && !$jis0212){
102             # fallback to '?'
103 0         0 $chunk =~ tr/\xA1-\xFE/\x3F/;
104             }else{
105 0         0 $chunk =~ tr/\xA1-\xFE/\x21-\x7E/;
106             }
107 0         0 $esc . $chunk . $ESC{ASC};
108             }geox;
109 2         51 $$r_str =~
110             s/\Q$ESC{ASC}\E
111             (\Q$ESC{KANA}\E|\Q$ESC_JISX0213_1\E|\Q$ESC_JISX0213_2\E)/$1/gox;
112 2         8 $$r_str;
113             }
114              
115             1;
116             __END__