File Coverage

lib/IOas/SJIS2004.pm
Criterion Covered Total %
statement 65 72 90.2
branch 26 34 76.4
condition 7 12 58.3
subroutine 24 24 100.0
pod 0 15 0.0
total 122 157 77.7


line stmt bran cond sub pod time code
1             package IOas::SJIS2004;
2             ######################################################################
3             #
4             # IOas::SJIS2004 - provides SJIS2004 I/O subroutines for UTF-8 script
5             #
6             # http://search.cpan.org/dist/IOas-SJIS2004/
7             #
8             # Copyright (c) 2019 INABA Hitoshi in a CPAN
9             ######################################################################
10              
11 12     12   38710 use 5.00503; # Universal Consensus 1998 for primetools
  12         107  
12             # use 5.008001; # Lancaster Consensus 2013 for toolchains
13              
14             $VERSION = '0.10';
15             $VERSION = $VERSION;
16              
17 12     12   106 use strict;
  12         24  
  12         422  
18 12 50   12   204 BEGIN { $INC{'warnings.pm'} = '' if $] < 5.006 }; use warnings; $^W=1;
  12     12   61  
  12         34  
  12         617  
19 12     12   5260 use Symbol ();
  12         9050  
  12         282  
20 12     12   75412 use Jacode4e::RoundTrip; # pmake.bat makes META.yml, META.json and Makefile.PL by /^use /
  12         31146444  
  12         16146  
21              
22             #-----------------------------------------------------------------------------
23             # import
24             #-----------------------------------------------------------------------------
25              
26             sub import {
27 12     12   126 my $self = shift @_;
28 12 50 33     486 if (defined($_[0]) and ($_[0] =~ /\A[0123456789]/)) {
29 0 0       0 if ($_[0] != $IOas::SJIS2004::VERSION) {
30 0         0 my($package,$filename,$line) = caller;
31 0         0 die "$filename requires @{[__PACKAGE__]} $_[0], this is version $IOas::SJIS2004::VERSION, stopped at $filename line $line.\n";
  0         0  
32             }
33 0         0 shift @_;
34             }
35             }
36              
37             #-----------------------------------------------------------------------------
38             # autodetect I/O encoding from package name
39             #-----------------------------------------------------------------------------
40              
41             (my $__package__ = __PACKAGE__) =~ s/utf81/utf8.1/i;
42             my $io_encoding = lc((split /::/, $__package__)[-1]);
43              
44             sub _io_input ($) {
45 58     58   117 my($s) = @_;
46 58 100       141 if (defined $s) {
47 56         140 Jacode4e::RoundTrip::convert(\$s, 'utf8.1', $io_encoding);
48             }
49 58         7070 return $s;
50             };
51              
52             sub _io_output ($) {
53 262     262   505 my($s) = @_;
54 262         1411 Jacode4e::RoundTrip::convert(\$s, $io_encoding, 'utf8.1', {
55             'OVERRIDE_MAPPING' => {
56              
57             # UTF-8.0 was popular in old days
58             "\xE2\x80\x95" => "\x81\x5C", # U+2015 HORIZONTAL BAR
59             "\xE2\x88\xA5" => "\x81\x61", # U+2225 PARALLEL TO
60             "\xEF\xBC\x8D" => "\x81\x7C", # U+FF0D FULLWIDTH HYPHEN-MINUS
61              
62             # UTF-8.1 will be popular in someday
63             "\xE2\x80\x94" => "\x81\x5C", # U+2014 EM DASH
64             "\xE2\x80\x96" => "\x81\x61", # U+2016 DOUBLE VERTICAL LINE
65             "\xE2\x88\x92" => "\x81\x7C", # U+2212 MINUS SIGN
66             },
67             });
68 262         24864 return $s;
69             };
70              
71             #-----------------------------------------------------------------------------
72             # Octet Length as I/O Encoding
73             #-----------------------------------------------------------------------------
74              
75             sub length (;$) {
76 18 100   18 0 563 return CORE::length _io_output(@_ ? $_[0] : $_);
77             }
78              
79             sub sprintf ($@) {
80 10     10 0 462 my($format, @list) = map { _io_output($_) } @_;
  19         38  
81 10         45 return _io_input(CORE::sprintf($format, @list));
82             }
83              
84             sub substr ($$;$$) {
85 6 100   6 0 302 if (@_ == 4) {
    100          
86 2         6 my $expr = _io_output($_[0]);
87 2         7 my $substr = CORE::substr($expr, $_[1], $_[2], _io_output($_[3]));
88 2         5 $_[0] = _io_input($expr);
89 2         28 return _io_input($substr);
90             }
91             elsif (@_ == 3) {
92 2         7 return _io_input(CORE::substr(_io_output($_[0]), $_[1], $_[2]));
93             }
94             else {
95 2         6 return _io_input(CORE::substr(_io_output($_[0]), $_[1]));
96             }
97             }
98              
99             #-----------------------------------------------------------------------------
100             # String Comparison as I/O Encoding
101             #-----------------------------------------------------------------------------
102              
103 20     20 0 796 sub cmp ($$) { _io_output($_[0]) cmp _io_output($_[1]) }
104 10     10 0 909 sub eq ($$) { _io_output($_[0]) eq _io_output($_[1]) } # must not optimize like "$_[0] eq $_[1]"
105 10     10 0 652 sub ne ($$) { _io_output($_[0]) ne _io_output($_[1]) } # must not optimize like "$_[0] ne $_[1]"
106 10     10 0 963 sub ge ($$) { _io_output($_[0]) ge _io_output($_[1]) }
107 10     10 0 778 sub gt ($$) { _io_output($_[0]) gt _io_output($_[1]) }
108 10     10 0 1551 sub le ($$) { _io_output($_[0]) le _io_output($_[1]) }
109 10     10 0 730 sub lt ($$) { _io_output($_[0]) lt _io_output($_[1]) }
110             sub sort (@) {
111 9         16 map { $_->[0] }
112 21         25 CORE::sort { $a->[1] cmp $b->[1] }
113 1     1 0 101 map { [ $_, _io_output($_) ] }
  9         17  
114             @_;
115             }
116              
117             #-----------------------------------------------------------------------------
118             # Encoding Convert on I/O Operations
119             #-----------------------------------------------------------------------------
120              
121             sub getc (;*) {
122 4 100   4 0 827 my $fh = @_ ? Symbol::qualify_to_ref($_[0],caller()) : \*STDIN;
123 4         86 my $octet = CORE::getc($fh);
124 4 50       25 if ($io_encoding =~ /^(?:sjis2004|cp932|cp932ibm|cp932nec|sjis2004)$/) {
125 4 50       10 if ($octet =~ /\A[\x81-\x9F\xE0-\xFC]\z/) {
126 4         11 $octet .= CORE::getc($fh);
127              
128             # ('cp932'.'x') to escape from build system
129 4 50 33     19 if (($io_encoding eq ('cp932'.'x')) and ($octet eq "\x9C\x5A")) {
130 0         0 $octet .= CORE::getc($fh);
131 0         0 $octet .= CORE::getc($fh);
132             }
133             }
134             }
135 4         16 return _io_input($octet);
136             }
137              
138             sub readline (;*) {
139 32 100   32 0 2470 my $fh = @_ ? Symbol::qualify_to_ref($_[0],caller()) : \*ARGV;
140 32 100       778 return wantarray ? map { _io_input($_) } <$fh> : _io_input(scalar <$fh>);
  6         25  
141             }
142              
143             sub print (;*@) {
144 10 100 100 10 0 3005 my $fh = ((@_ >= 1) and defined(fileno(Symbol::qualify_to_ref($_[0],caller())))) ? Symbol::qualify_to_ref(shift,caller()) : Symbol::qualify_to_ref(select,caller());
145 10 100       292 return CORE::print {$fh} (map { _io_output($_) } (@_ ? @_ : $_));
  10         24  
  10         16  
146             }
147              
148             sub printf (;*@) {
149 20 100 66 20 0 4479 my $fh = ((@_ >= 1) and defined(fileno(Symbol::qualify_to_ref($_[0],caller())))) ? Symbol::qualify_to_ref(shift,caller()) : Symbol::qualify_to_ref(select,caller());
150 20 50       632 my($format, @list) = map { _io_output($_) } (@_ ? @_ : $_);
  38         63  
151 20         34 return CORE::printf {$fh} ($format, @list);
  20         141  
152             }
153              
154             1;
155              
156             __END__