File Coverage

blib/lib/Greek.pm
Criterion Covered Total %
statement 79 134 58.9
branch 29 74 39.1
condition 0 3 0.0
subroutine 11 13 84.6
pod 0 2 0.0
total 119 226 52.6


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