File Coverage

lib/IOas/CP932NEC.pm
Criterion Covered Total %
statement 64 71 90.1
branch 24 32 75.0
condition 7 12 58.3
subroutine 24 24 100.0
pod 0 15 0.0
total 119 154 77.2


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