File Coverage

blib/lib/EUCJP.pm
Criterion Covered Total %
statement 64 124 51.6
branch 22 70 31.4
condition 0 3 0.0
subroutine 9 11 81.8
pod 0 2 0.0
total 95 210 45.2


line stmt bran cond sub pod time code
1             package EUCJP;
2 329     329   296827 use strict;
  329         2913  
  329         10350  
3             ######################################################################
4             #
5             # EUCJP - Source code filter to escape EUC-JP script
6             #
7             # http://search.cpan.org/dist/Char-EUCJP/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 329     329   11039 use 5.00503; # Galapagos Consensus 1998 for primetools
  329         1397  
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 329     329   1966 use vars qw($VERSION);
  329         549  
  329         74937  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 329 50   329   2499 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 329         574 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 329         41052 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 329     329   3862 (my $dirname = __FILE__) =~ s{^(.+)/[^/]*$}{$1};
45 329         17565 unshift @INC, $dirname;
46 329         516947 CORE::require Eeucjp;
47             }
48              
49             # instead of Symbol.pm
50 987         1668 BEGIN {
51             sub gensym () {
52 987     987 0 7050 return \do { local *_ };
  329         23501  
53             }
54             }
55              
56             # P.714 29.2.39. flock
57             # in Chapter 29: Functions
58             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
59              
60             # P.863 flock
61             # in Chapter 27: Functions
62             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
63              
64             # P.228 Inlining Constant Functions
65             # in Chapter 6: Subroutines
66             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
67              
68             # P.331 Inlining Constant Functions
69             # in Chapter 7: Subroutines
70             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
71              
72             sub LOCK_SH() {1}
73             sub LOCK_EX() {2}
74             sub LOCK_UN() {8}
75             sub LOCK_NB() {4}
76              
77       0     sub unimport {}
78             sub EUCJP::escape_script;
79              
80             # 6.18. Matching Multiple-Byte Characters
81             # in Chapter 6. Pattern Matching
82             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
83             # (and so on)
84              
85             # regexp of character
86             my $qq_char = qr/(?> \\c[\x40-\x5F] | \\? (?:[\x8E\xA1-\xFE][\xA1-\xFE]|\x8F[\xA1-\xFE][\x00-\xFF] | [\x00-\xFF]) )/oxms;
87             my $q_char = qr/(?> [\x8E\xA1-\xFE][\xA1-\xFE]|\x8F[\xA1-\xFE][\x00-\xFF] | [\x00-\xFF] )/oxms;
88              
89             # when this script is main program
90             if ($0 eq __FILE__) {
91              
92             # show usage
93             unless (@ARGV) {
94             die <
95             $0: usage
96              
97             perl $0 EUC-JP_script.pl > Escaped_script.pl.e
98             END
99             }
100              
101             print EUCJP::escape_script($ARGV[0]);
102             exit 0;
103             }
104              
105             my($package,$filename,$line,$subroutine,$hasargs,$wantarray,$evaltext,$is_require,$hints,$bitmask) = caller 0;
106              
107             # called any package not main
108             if ($package ne 'main') {
109             die <
110             @{[__FILE__]}: escape by manually command '$^X @{[__FILE__]} "$filename" > "@{[__PACKAGE__]}::$filename"'
111             and rewrite "use $package;" to "use @{[__PACKAGE__]}::$package;" of script "$0".
112             END
113             }
114              
115             # P.302 Module Privacy and the Exporter
116             # in Chapter 11: Modules
117             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
118             #
119             # A module can do anything it jolly well pleases when it's used, since use just
120             # calls the ordinary import method for the module, and you can define that
121             # method to do anything you like.
122              
123             # P.406 Module Privacy and the Exporter
124             # in Chapter 11: Modules
125             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
126             #
127             # A module can do anything it jolly well pleases when it's used, since use just
128             # calls the ordinary import method for the module, and you can define that
129             # method to do anything you like.
130              
131             sub import {
132              
133 0 50   329   0 if (-e("$filename.e")) {
134 0 0       0 if (exists $ENV{'CHAR_DEBUG'}) {
    0          
135 0         0 unlink "$filename.e";
136             }
137             elsif (-z("$filename.e")) {
138 0         0 unlink "$filename.e";
139             }
140             else {
141              
142             #----------------------------------------------------
143             # older >
144             # newer >>>>>
145             #----------------------------------------------------
146             # Filter >
147             # Source >>>>>
148             # Escape >>> needs re-escape (Source was changed)
149             #
150             # Filter >>>
151             # Source >>>>>
152             # Escape > needs re-escape (Source was changed)
153             #
154             # Filter >>>>>
155             # Source >>>
156             # Escape > needs re-escape (Source was changed)
157             #
158             # Filter >>>>>
159             # Source >
160             # Escape >>> needs re-escape (Filter was changed)
161             #
162             # Filter >
163             # Source >>>
164             # Escape >>>>> executable without re-escape
165             #
166             # Filter >>>
167             # Source >
168             # Escape >>>>> executable without re-escape
169             #----------------------------------------------------
170              
171 0         0 my $mtime_filter = (stat(__FILE__ ))[9];
172 0         0 my $mtime_source = (stat($filename ))[9];
173 0         0 my $mtime_escape = (stat("$filename.e"))[9];
174 0 0 0     0 if (($mtime_escape < $mtime_source) or ($mtime_escape < $mtime_filter)) {
175 329         6262 unlink "$filename.e";
176             }
177             }
178             }
179              
180 329 50       2749 if (not -e("$filename.e")) {
181 329         1947 my $fh = gensym();
182 329 50       3209 Eeucjp::_open_a($fh, "$filename.e") or die __FILE__, ": Can't write open file: $filename.e\n";
183              
184             # 7.19. Flushing Output
185             # in Chapter 7. File Access
186             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
187              
188 329         1713 select((select($fh), $|=1)[0]);
189              
190 0 50       0 if (0) {
191             }
192 0         0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
193              
194             # P.419 File Locking
195             # in Chapter 16: Interprocess Communication
196             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
197              
198             # P.524 File Locking
199             # in Chapter 15: Interprocess Communication
200             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
201              
202             # P.571 Handling Race Conditions
203             # in Chapter 23: Security
204             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
205              
206             # P.663 Handling Race Conditions
207             # in Chapter 20: Security
208             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
209              
210             # (and so on)
211              
212 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
213 0 0       0 if ($@) {
214 329         37105 die __FILE__, ": Can't immediately write-lock the file: $filename.e\n";
215             }
216             }
217             else {
218 329         14809 CORE::eval q{ flock($fh, LOCK_EX) };
219             }
220              
221 329         4192 CORE::eval q{ truncate($fh, 0) };
222 329 50       1269 seek($fh, 0, 0) or die __FILE__, ": Can't seek file: $filename.e\n";
223              
224 329         750 my $e_script = EUCJP::escape_script($filename);
225 329         38383 print {$fh} $e_script;
  329         11550  
226              
227 329         8470 my $mode = (stat($filename))[2] & 0777;
228 329         71291 chmod $mode, "$filename.e";
229              
230 329 50       2257 close($fh) or die __FILE__, ": Can't close file: $filename.e\n";
231             }
232              
233 329         2301 my $fh = gensym();
234 329 50       2394 Eeucjp::_open_r($fh, "$filename.e") or die __FILE__, ": Can't read open file: $filename.e\n";
235              
236 0 50       0 if (0) {
237             }
238 0         0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
239 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
240 0 0       0 if ($@) {
241 329         26056 die __FILE__, ": Can't immediately read-lock the file: $filename.e\n";
242             }
243             }
244             else {
245 329         1673 CORE::eval q{ flock($fh, LOCK_SH) };
246             }
247              
248 329         1752 my @switch = ();
249 0 50       0 if ($^W) {
250 329         1448 push @switch, '-w';
251             }
252 0 50       0 if (defined $^I) {
253 0         0 push @switch, '-i' . $^I;
254 329         688 undef $^I;
255             }
256              
257             # P.707 29.2.33. exec
258             # in Chapter 29: Functions
259             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
260             #
261             # If there is more than one argument in LIST, or if LIST is an array with more
262             # than one value, the system shell will never be used. This also bypasses any
263             # shell processing of the command. The presence or absence of metacharacters in
264             # the arguments doesn't affect this list-triggered behavior, which makes it the
265             # preferred from in security-conscious programs that do not with to expose
266             # themselves to potential shell escapes.
267             # Environment variable PERL5SHELL(Microsoft ports only) will never be used, too.
268              
269             # P.855 exec
270             # in Chapter 27: Functions
271             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
272             #
273             # If there is more than one argument in LIST, or if LIST is an array with more
274             # than one value, the system shell will never be used. This also bypasses any
275             # shell processing of the command. The presence or absence of metacharacters in
276             # the arguments doesn't affect this list-triggered behavior, which makes it the
277             # preferred from in security-conscious programs that do not wish to expose
278             # themselves to injection attacks via shell escapes.
279             # Environment variable PERL5SHELL(Microsoft ports only) will never be used, too.
280              
281             # P.489 #! and Quoting on Non-Unix Systems
282             # in Chapter 19: The Command-Line Interface
283             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
284              
285             # P.578 #! and Quoting on Non-Unix Systems
286             # in Chapter 17: The Command-Line Interface
287             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
288              
289 329         2359 my $system = 0;
290              
291             # DOS-like system
292 0 50       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
293             $system = Eeucjp::_systemx(
294             _escapeshellcmd_MSWin32($^X),
295              
296             # -I switch can not treat space included path
297             # (map { '-I' . _escapeshellcmd_MSWin32($_) } @INC),
298 0         0 (map { '-I' . $_ } @INC),
299              
300             @switch,
301             '--',
302 0         0 map { _escapeshellcmd_MSWin32($_) } "$filename.e", @ARGV
  329         1385  
303             );
304             }
305              
306             # UNIX-like system
307             else {
308             $system = Eeucjp::_systemx(
309             _escapeshellcmd($^X),
310 329         1411 (map { '-I' . _escapeshellcmd($_) } @INC),
311             @switch,
312             '--',
313 3948         5630 map { _escapeshellcmd($_) } "$filename.e", @ARGV
  329         639942  
314             );
315             }
316              
317             # exit with actual exit value
318 0         0 exit($system >> 8);
319             }
320              
321             # escape shell command line on DOS-like system
322             sub _escapeshellcmd_MSWin32 {
323 0     0   0 my($word) = @_;
324 0 0       0 if ($word =~ / [ ] /oxms) {
325 0         0 return qq{"$word"};
326             }
327             else {
328 4606         6998 return $word;
329             }
330             }
331              
332             # escape shell command line on UNIX-like system
333             sub _escapeshellcmd {
334 4606     4606   12930 my($word) = @_;
335 329         848 return $word;
336             }
337              
338             # P.619 Source Filters
339             # in Chapter 24: Common Practices
340             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
341              
342             # P.718 Source Filters
343             # in Chapter 21: Common Practices
344             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
345              
346             # escape EUC-JP script
347             sub EUCJP::escape_script {
348 329     329 0 563 my($script) = @_;
349 329         730 my $e_script = '';
350              
351             # read EUC-JP script
352 329         1448 my $fh = gensym();
353 329 50       11477 Eeucjp::_open_r($fh, $script) or die __FILE__, ": Can't open file: $script\n";
354 329         7046 local $/ = undef; # slurp mode
355 329         4215 $_ = <$fh>;
356 329 50       2191 close($fh) or die __FILE__, ": Can't close file: $script\n";
357              
358 0 50       0 if (/^ use Eeucjp(?:(?>\s+)(?>[0-9\.]*))?(?>\s*); $/oxms) {
359 329         1077 return $_;
360             }
361             else {
362              
363             # #! shebang line
364 0 50       0 if (s/\A(#!.+?\n)//oms) {
365 0         0 my $head = $1;
366 0         0 $head =~ s/\bjperl\b/perl/gi;
367 329         914 $e_script .= $head;
368             }
369              
370             # DOS-like system header
371 0 50       0 if (s/\A(\@rem(?>\s*)=(?>\s*)'.*?'(?>\s*);\s*\n)//oms) {
372 0         0 my $head = $1;
373 0         0 $head =~ s/\bjperl\b/perl/gi;
374 329         20185 $e_script .= $head;
375             }
376              
377             # P.618 Generating Perl in Other Languages
378             # in Chapter 24: Common Practices
379             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
380              
381             # P.717 Generating Perl in Other Languages
382             # in Chapter 21: Common Practices
383             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
384              
385 0 50       0 if (s/(.*^#(?>\s*)line(?>\s+)(?>[0-9]+)(?:(?>\s+)"(?:$q_char)+?")?\s*\n)//oms) {
386 0         0 my $head = $1;
387 0         0 $head =~ s/\bjperl\b/perl/gi;
388 329         1861 $e_script .= $head;
389             }
390              
391             # P.210 5.10.3.3. Match-time code evaluation
392             # in Chapter 5: Pattern Matching
393             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
394              
395             # P.255 Match-time code evaluation
396             # in Chapter 5: Pattern Matching
397             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
398              
399             # '...' quote to avoid "Octal number in vector unsupported" on perl 5.6
400              
401 329         3786 $e_script .= sprintf("use Eeucjp '%s.0'; # 'quote' for perl5.6\n", $EUCJP::VERSION); # require run-time routines version
402              
403             # use EUCJP version qw(ord reverse getc);
404 329 50       1085 if (s/^ (?>\s*) use (?>\s+) (?: Char | EUCJP ) (?>\s*) ([^\x8E\x8F\xA1-\xFE;]*) ; \s* \n? $//oxms) {
405              
406             # require version
407 329         1371 my $list = $1;
408 0 50       0 if ($list =~ s/\A ((?>[0-9]+)\.(?>[0-9]+)) \.0 (?>\s*) //oxms) {
    50          
409 0         0 my $version = $1;
410 0 0       0 if ($version ne $EUCJP::VERSION) {
411 0         0 my @file = grep -e, map {qq{$_/EUCJP.pm}} @INC;
  0         0  
412 0         0 my %file = map { $_ => 1 } @file;
  0         0  
413 0 0       0 if (scalar(keys %file) >= 2) {
414 0         0 my $file = join "\n", sort keys %file;
415 0         0 warn <
416             ****************************************************
417             C A U T I O N
418              
419             CONFLICT EUCJP.pm FILE
420              
421             $file
422             ****************************************************
423              
424             END
425             }
426 0         0 die "Script $0 expects EUCJP.pm $version, but @{[__FILE__]} is version $EUCJP::VERSION\n";
  0         0  
427             }
428 0         0 $e_script .= qq{die "Script \$0 expects Eeucjp.pm $version, but \\\$Eeucjp::VERSION is \$Eeucjp::VERSION" if \$Eeucjp::VERSION ne '$version';\n};
429             }
430             elsif ($list =~ s/\A ((?>[0-9]+)(?>\.[0-9]*)) (?>\s*) //oxms) {
431 0         0 my $version = $1;
432 0 0       0 if ($version > $EUCJP::VERSION) {
433 0         0 die "Script $0 required EUCJP.pm $version, but @{[__FILE__]} is only version $EUCJP::VERSION\n";
  329         1642  
434             }
435             }
436              
437             # demand ord, reverse, and getc
438 0 50       0 if ($list !~ /\A (?>\s*) \z/oxms) {
439 0         0 local $@;
440 0         0 my @list = CORE::eval $list;
441 0         0 for (@list) {
442 0 0       0 $Eeucjp::function_ord = 'EUCJP::ord' if /\A ord \z/oxms;
443 0 0       0 $Eeucjp::function_ord_ = 'EUCJP::ord_' if /\A ord \z/oxms;
444 0 0       0 $Eeucjp::function_reverse = 'EUCJP::reverse' if /\A reverse \z/oxms;
445 329 0       1347 $Eeucjp::function_getc = 'EUCJP::getc' if /\A getc \z/oxms;
446             }
447             }
448             }
449             }
450              
451 329         3008 $e_script .= EUCJP::escape();
452              
453             return $e_script;
454             }
455              
456             1;
457              
458             __END__