File Coverage

blib/lib/Sjis.pm
Criterion Covered Total %
statement 65 136 47.7
branch 27 80 33.7
condition 0 3 0.0
subroutine 9 12 75.0
pod 0 2 0.0
total 101 233 43.3


line stmt bran cond sub pod time code
1             package Sjis;
2 385     385   325112 use strict;
  385         2832  
  385         12779  
3             ######################################################################
4             #
5             # Sjis - Source code filter to escape ShiftJIS script
6             #
7             # http://search.cpan.org/dist/Char-Sjis/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 385     385   9289 use 5.00503; # Galapagos Consensus 1998 for primetools
  385         1219  
13             # use 5.008001; # Lancaster Consensus 2013 for toolchains
14              
15             # 12.3. Delaying use Until Runtime
16             # in Chapter 12. Packages, Libraries, and Modules
17             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
18             # (and so on)
19              
20             # Version numbers should be boring
21             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
22             # For the impatient, the disinterested or those who just want to follow
23             # a recipe, my advice for all modules is this:
24             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
25             # $VERSION = CORE::eval $VERSION; # No!! because '1.10' makes '1.1'
26              
27 385     385   2955 use vars qw($VERSION);
  385         632  
  385         89011  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 385 50   385   4913 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 385         647 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 385         29541 if (CORE::ord('A') != 0x41) {
39             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
40             }
41             }
42              
43             BEGIN {
44 385     385   8014 (my $dirname = __FILE__) =~ s{^(.+)/[^/]*$}{$1};
45 385         5491 unshift @INC, $dirname;
46 385         842950 CORE::require Esjis;
47             }
48              
49             # instead of Symbol.pm
50 1155         3784 BEGIN {
51             sub gensym () {
52 0 50   1155 0 0 if ($] < 5.006) {
53 0         0 return \do { local *_ };
  1155         3334  
54             }
55             else {
56 385         4454 return undef;
57             }
58             }
59             }
60              
61             # P.714 29.2.39. flock
62             # in Chapter 29: Functions
63             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
64              
65             # P.863 flock
66             # in Chapter 27: Functions
67             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
68              
69             # P.228 Inlining Constant Functions
70             # in Chapter 6: Subroutines
71             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
72              
73             # P.331 Inlining Constant Functions
74             # in Chapter 7: Subroutines
75             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
76              
77             sub LOCK_SH() {1}
78             sub LOCK_EX() {2}
79             sub LOCK_UN() {8}
80             sub LOCK_NB() {4}
81              
82       0     sub unimport {}
83             sub Sjis::escape_script;
84              
85             # 6.18. Matching Multiple-Byte Characters
86             # in Chapter 6. Pattern Matching
87             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
88             # (and so on)
89              
90             # regexp of character
91             my $qq_char = qr/(?> \\c[\x40-\x5F] | \\? (?:[\x81-\x9F\xE0-\xFC][\x00-\xFF] | [\x00-\xFF]) )/oxms;
92             my $q_char = qr/(?> [\x81-\x9F\xE0-\xFC][\x00-\xFF] | [\x00-\xFF] )/oxms;
93              
94             # when this script is main program
95             if ($0 eq __FILE__) {
96              
97             # show usage
98             unless (@ARGV) {
99             die <
100             $0: usage
101              
102             perl $0 ShiftJIS_script.pl > Escaped_script.pl.e
103             END
104             }
105              
106             print Sjis::escape_script($ARGV[0]);
107             exit 0;
108             }
109              
110             my($package,$filename,$line,$subroutine,$hasargs,$wantarray,$evaltext,$is_require,$hints,$bitmask) = caller 0;
111              
112             # called any package not main
113             if ($package ne 'main') {
114             die <
115             @{[__FILE__]}: escape by manually command '$^X @{[__FILE__]} "$filename" > "@{[__PACKAGE__]}::$filename"'
116             and rewrite "use $package;" to "use @{[__PACKAGE__]}::$package;" of script "$0".
117             END
118             }
119              
120             # P.302 Module Privacy and the Exporter
121             # in Chapter 11: Modules
122             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
123             #
124             # A module can do anything it jolly well pleases when it's used, since use just
125             # calls the ordinary import method for the module, and you can define that
126             # method to do anything you like.
127              
128             # P.406 Module Privacy and the Exporter
129             # in Chapter 11: Modules
130             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
131             #
132             # A module can do anything it jolly well pleases when it's used, since use just
133             # calls the ordinary import method for the module, and you can define that
134             # method to do anything you like.
135              
136             sub import {
137              
138 0 50   385   0 if (Esjis::e("$filename.e")) {
139 0 0       0 if (exists $ENV{'CHAR_DEBUG'}) {
    0          
140 0         0 Esjis::unlink "$filename.e";
141             }
142             elsif (Esjis::z("$filename.e")) {
143 0         0 Esjis::unlink "$filename.e";
144             }
145             else {
146              
147             #----------------------------------------------------
148             # older >
149             # newer >>>>>
150             #----------------------------------------------------
151             # Filter >
152             # Source >>>>>
153             # Escape >>> needs re-escape (Source was changed)
154             #
155             # Filter >>>
156             # Source >>>>>
157             # Escape > needs re-escape (Source was changed)
158             #
159             # Filter >>>>>
160             # Source >>>
161             # Escape > needs re-escape (Source was changed)
162             #
163             # Filter >>>>>
164             # Source >
165             # Escape >>> needs re-escape (Filter was changed)
166             #
167             # Filter >
168             # Source >>>
169             # Escape >>>>> executable without re-escape
170             #
171             # Filter >>>
172             # Source >
173             # Escape >>>>> executable without re-escape
174             #----------------------------------------------------
175              
176 0         0 my $mtime_filter = (Esjis::stat(__FILE__ ))[9];
177 0         0 my $mtime_source = (Esjis::stat($filename ))[9];
178 0         0 my $mtime_escape = (Esjis::stat("$filename.e"))[9];
179 0 0 0     0 if (($mtime_escape < $mtime_source) or ($mtime_escape < $mtime_filter)) {
180 385         2704 Esjis::unlink "$filename.e";
181             }
182             }
183             }
184              
185 385 50       1333 if (not Esjis::e("$filename.e")) {
186 385         1969 my $fh = gensym();
187 385 50       3760 Esjis::_open_a($fh, "$filename.e") or die __FILE__, ": Can't write open file: $filename.e\n";
188              
189             # 7.19. Flushing Output
190             # in Chapter 7. File Access
191             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
192              
193 385         2406 select((select($fh), $|=1)[0]);
194              
195 0 50       0 if (0) {
    50          
196             }
197 0         0 elsif ($^O eq 'MacOS') {
198 0         0 CORE::eval q{
199             CORE::require Mac::Files;
200             Mac::Files::FSpSetFLock("$filename.e");
201             };
202             }
203             elsif (exists $ENV{'CHAR_NONBLOCK'}) {
204              
205             # P.419 File Locking
206             # in Chapter 16: Interprocess Communication
207             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
208              
209             # P.524 File Locking
210             # in Chapter 15: Interprocess Communication
211             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
212              
213             # P.571 Handling Race Conditions
214             # in Chapter 23: Security
215             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
216              
217             # P.663 Handling Race Conditions
218             # in Chapter 20: Security
219             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
220              
221             # (and so on)
222              
223 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
224 0 0       0 if ($@) {
225 385         25963 die __FILE__, ": Can't immediately write-lock the file: $filename.e\n";
226             }
227             }
228             else {
229 385         29294 CORE::eval q{ flock($fh, LOCK_EX) };
230             }
231              
232 385         6038 CORE::eval q{ truncate($fh, 0) };
233 385 50       1774 seek($fh, 0, 0) or die __FILE__, ": Can't seek file: $filename.e\n";
234              
235 385         1047 my $e_script = Sjis::escape_script($filename);
236 385         47417 print {$fh} $e_script;
  385         4921  
237              
238 385         28623 my $mode = (Esjis::stat($filename))[2] & 0777;
239 385         3015 chmod $mode, "$filename.e";
240              
241 0 50       0 if ($^O eq 'MacOS') {
242 385         58449 CORE::eval q{
243             CORE::require Mac::Files;
244             Mac::Files::FSpRstFLock("$filename.e");
245             };
246             }
247              
248 385 50       3124 close($fh) or die "Can't close file: $filename.e: $!";
249             }
250              
251 385         2993 my $fh = gensym();
252 385 50       3620 Esjis::_open_r($fh, "$filename.e") or die __FILE__, ": Can't read open file: $filename.e\n";
253              
254 0 50       0 if (0) {
    50          
255             }
256 0         0 elsif ($^O eq 'MacOS') {
257 0         0 CORE::eval q{
258             CORE::require Mac::Files;
259             Mac::Files::FSpSetFLock("$filename.e");
260             };
261             }
262             elsif (exists $ENV{'CHAR_NONBLOCK'}) {
263 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
264 0 0       0 if ($@) {
265 385         34869 die __FILE__, ": Can't immediately read-lock the file: $filename.e\n";
266             }
267             }
268             else {
269 385         1977 CORE::eval q{ flock($fh, LOCK_SH) };
270             }
271              
272 385         2124 my @switch = ();
273 0 50       0 if ($^W) {
274 385         1800 push @switch, '-w';
275             }
276 0 50       0 if (defined $^I) {
277 0         0 push @switch, '-i' . $^I;
278 385         877 undef $^I;
279             }
280              
281             # P.707 29.2.33. exec
282             # in Chapter 29: Functions
283             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
284             #
285             # If there is more than one argument in LIST, or if LIST is an array with more
286             # than one value, the system shell will never be used. This also bypasses any
287             # shell processing of the command. The presence or absence of metacharacters in
288             # the arguments doesn't affect this list-triggered behavior, which makes it the
289             # preferred from in security-conscious programs that do not with to expose
290             # themselves to potential shell escapes.
291             # Environment variable PERL5SHELL(Microsoft ports only) will never be used, too.
292              
293             # P.855 exec
294             # in Chapter 27: Functions
295             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
296             #
297             # If there is more than one argument in LIST, or if LIST is an array with more
298             # than one value, the system shell will never be used. This also bypasses any
299             # shell processing of the command. The presence or absence of metacharacters in
300             # the arguments doesn't affect this list-triggered behavior, which makes it the
301             # preferred from in security-conscious programs that do not wish to expose
302             # themselves to injection attacks via shell escapes.
303             # Environment variable PERL5SHELL(Microsoft ports only) will never be used, too.
304              
305             # P.489 #! and Quoting on Non-Unix Systems
306             # in Chapter 19: The Command-Line Interface
307             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
308              
309             # P.578 #! and Quoting on Non-Unix Systems
310             # in Chapter 17: The Command-Line Interface
311             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
312              
313 385         3255 my $system = 0;
314              
315             # DOS-like system
316 0 50       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
    50          
317             $system = Esjis::_systemx(
318             _escapeshellcmd_MSWin32($^X),
319              
320             # -I switch can not treat space included path
321             # (map { '-I' . _escapeshellcmd_MSWin32($_) } @INC),
322 0         0 (map { '-I' . $_ } @INC),
323              
324             @switch,
325             '--',
326 0         0 map { _escapeshellcmd_MSWin32($_) } "$filename.e", @ARGV
  0         0  
327             );
328             }
329              
330             # MacOS system
331             elsif ($^O eq 'MacOS') {
332             $system = Esjis::_systemx(
333             _escapeshellcmd_MacOS($^X),
334 0         0 (map { '-I' . _escapeshellcmd_MacOS($_) } @INC),
335             @switch,
336             '--',
337 0         0 map { _escapeshellcmd_MacOS($_) } "$filename.e", @ARGV
  0         0  
338             );
339 385         3220 CORE::eval q{
340             CORE::require Mac::Files;
341             Mac::Files::FSpRstFLock("$filename.e");
342             };
343             }
344              
345             # UNIX-like system
346             else {
347             $system = Esjis::_systemx(
348             _escapeshellcmd($^X),
349 385         1187 (map { '-I' . _escapeshellcmd($_) } @INC),
350             @switch,
351             '--',
352 4620         6831 map { _escapeshellcmd($_) } "$filename.e", @ARGV
  385         753441  
353             );
354             }
355              
356             # exit with actual exit value
357 0         0 exit($system >> 8);
358             }
359              
360             # escape shell command line on DOS-like system
361             sub _escapeshellcmd_MSWin32 {
362 0     0   0 my($word) = @_;
363 0 0       0 if ($word =~ / [ ] /oxms) {
364 0         0 return qq{"$word"};
365             }
366             else {
367 0         0 return $word;
368             }
369             }
370              
371             # escape shell command line on Mac OS
372             sub _escapeshellcmd_MacOS {
373 0     0   0 my($word) = @_;
374 5390         8561 return $word;
375             }
376              
377             # escape shell command line on UNIX-like system
378             sub _escapeshellcmd {
379 5390     5390   26169 my($word) = @_;
380 385         964 return $word;
381             }
382              
383             # P.619 Source Filters
384             # in Chapter 24: Common Practices
385             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
386              
387             # P.718 Source Filters
388             # in Chapter 21: Common Practices
389             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
390              
391             # escape ShiftJIS script
392             sub Sjis::escape_script {
393 385     385 0 681 my($script) = @_;
394 385         914 my $e_script = '';
395              
396             # read ShiftJIS script
397 385         1535 my $fh = gensym();
398 385 50       2113 Esjis::_open_r($fh, $script) or die __FILE__, ": Can't open file: $script\n";
399 385         8531 local $/ = undef; # slurp mode
400 385         4817 $_ = <$fh>;
401 385 50       2293 close($fh) or die "Can't close file: $script: $!";
402              
403 0 50       0 if (/^ use Esjis(?:(?>\s+)(?>[0-9\.]*))?(?>\s*); $/oxms) {
404 385         1305 return $_;
405             }
406             else {
407              
408             # #! shebang line
409 0 50       0 if (s/\A(#!.+?\n)//oms) {
410 0         0 my $head = $1;
411 0         0 $head =~ s/\bjperl\b/perl/gi;
412 385         1190 $e_script .= $head;
413             }
414              
415             # DOS-like system header
416 0 50       0 if (s/\A(\@rem(?>\s*)=(?>\s*)'.*?'(?>\s*);\s*\n)//oms) {
417 0         0 my $head = $1;
418 0         0 $head =~ s/\bjperl\b/perl/gi;
419 385         16492 $e_script .= $head;
420             }
421              
422             # P.618 Generating Perl in Other Languages
423             # in Chapter 24: Common Practices
424             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
425              
426             # P.717 Generating Perl in Other Languages
427             # in Chapter 21: Common Practices
428             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
429              
430 0 50       0 if (s/(.*^#(?>\s*)line(?>\s+)(?>[0-9]+)(?:(?>\s+)"(?:$q_char)+?")?\s*\n)//oms) {
431 0         0 my $head = $1;
432 0         0 $head =~ s/\bjperl\b/perl/gi;
433 385         2296 $e_script .= $head;
434             }
435              
436             # P.210 5.10.3.3. Match-time code evaluation
437             # in Chapter 5: Pattern Matching
438             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
439              
440             # P.255 Match-time code evaluation
441             # in Chapter 5: Pattern Matching
442             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
443              
444             # '...' quote to avoid "Octal number in vector unsupported" on perl 5.6
445              
446 385         6051 $e_script .= sprintf("use Esjis '%s.0'; # 'quote' for perl5.6\n", $Sjis::VERSION); # require run-time routines version
447              
448             # use Sjis version qw(ord reverse getc);
449 385 50       1242 if (s/^ (?>\s*) use (?>\s+) (?: Char | Sjis ) (?>\s*) ([^\x81-\x9F\xE0-\xFC;]*) ; \s* \n? $//oxms) {
450              
451             # require version
452 385         1597 my $list = $1;
453 0 50       0 if ($list =~ s/\A ((?>[0-9]+)\.(?>[0-9]+)) \.0 (?>\s*) //oxms) {
    50          
454 0         0 my $version = $1;
455 0 0       0 if ($version ne $Sjis::VERSION) {
456 0         0 my @file = grep -e, map {qq{$_/Sjis.pm}} @INC;
  0         0  
457 0         0 my %file = map { $_ => 1 } @file;
  0         0  
458 0 0       0 if (scalar(keys %file) >= 2) {
459 0         0 my $file = join "\n", sort keys %file;
460 0         0 warn <
461             ****************************************************
462             C A U T I O N
463              
464             CONFLICT Sjis.pm FILE
465              
466             $file
467             ****************************************************
468              
469             END
470             }
471 0         0 die "Script $0 expects Sjis.pm $version, but @{[__FILE__]} is version $Sjis::VERSION\n";
  0         0  
472             }
473 0         0 $e_script .= qq{die "Script \$0 expects Esjis.pm $version, but \\\$Esjis::VERSION is \$Esjis::VERSION" if \$Esjis::VERSION ne '$version';\n};
474             }
475             elsif ($list =~ s/\A ((?>[0-9]+)(?>\.[0-9]*)) (?>\s*) //oxms) {
476 0         0 my $version = $1;
477 0 0       0 if ($version > $Sjis::VERSION) {
478 0         0 die "Script $0 required Sjis.pm $version, but @{[__FILE__]} is only version $Sjis::VERSION\n";
  385         1901  
479             }
480             }
481              
482             # demand ord, reverse, and getc
483 0 50       0 if ($list !~ /\A (?>\s*) \z/oxms) {
484 0         0 local $@;
485 0         0 my @list = CORE::eval $list;
486 0         0 for (@list) {
487 0 0       0 $Esjis::function_ord = 'Sjis::ord' if /\A ord \z/oxms;
488 0 0       0 $Esjis::function_ord_ = 'Sjis::ord_' if /\A ord \z/oxms;
489 0 0       0 $Esjis::function_reverse = 'Sjis::reverse' if /\A reverse \z/oxms;
490 385 0       1548 $Esjis::function_getc = 'Sjis::getc' if /\A getc \z/oxms;
491             }
492             }
493             }
494             }
495              
496 385         4193 $e_script .= Sjis::escape();
497              
498             return $e_script;
499             }
500              
501             1;
502              
503             __END__