File Coverage

blib/lib/OldUTF8.pm
Criterion Covered Total %
statement 70 132 53.0
branch 23 74 31.0
condition 1 6 16.6
subroutine 12 14 85.7
pod 0 2 0.0
total 106 228 46.4


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