File Coverage

Char/Greek.pm
Criterion Covered Total %
statement 41 122 33.6
branch 11 68 16.1
condition 1 6 16.6
subroutine 10 13 76.9
pod 0 2 0.0
total 63 211 29.8


line stmt bran cond sub pod time code
1             #
2             # This file is *** FOR CPAN USE ONLY ***.
3             #
4             # If you are an application programmer, please use file that 'Char::' removed.
5             #
6             package Char::Greek;
7             ######################################################################
8             #
9             # Char::Greek - Source code filter to escape Greek script
10             #
11             # http://search.cpan.org/dist/Char-Greek/
12             #
13             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
14             ######################################################################
15              
16 197     197   188375 use 5.00503; # Galapagos Consensus 1998 for primetools
  197         684  
  197         11769  
17             # use 5.008001; # Lancaster Consensus 2013 for toolchains
18              
19             # 12.3. Delaying use Until Runtime
20             # in Chapter 12. Packages, Libraries, and Modules
21             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
22             # (and so on)
23              
24 197     197   13564 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  197     197   1825  
  197         342  
  197         40780  
25             $VERSION = sprintf '%d.%02d', q$Revision: 1.02 $ =~ /(\d+)/oxmsg;
26              
27             BEGIN {
28 197 50   197   1361 if ($^X =~ / jperl /oxmsi) {
29 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)";
30             }
31 197         300 if (CORE::ord('A') == 193) {
32             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).";
33             }
34 197         5205 if (CORE::ord('A') != 0x41) {
35             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).";
36             }
37             }
38              
39 197     197   442063 BEGIN { CORE::require Char::Egreek; }
40              
41             # instead of Symbol.pm
42             BEGIN {
43 197     197   548 my $genpkg = "Symbol::";
44 197         10222 my $genseq = 0;
45             sub gensym () {
46 197     197 0 879 my $name = "GEN" . $genseq++;
47              
48             # here, no strict qw(refs); if strict.pm exists
49              
50 197         394 my $ref = \*{$genpkg . $name};
  197         2234  
51 197         1165 delete $$genpkg{$name};
52 197         647 $ref;
53             }
54             }
55              
56             # Column: local $@
57             # in Chapter 9. Osaete okitai Perl no kiso
58             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
59             # (and so on)
60              
61             # use strict; if strict.pm exists
62             BEGIN {
63 197 50   197   611 if (CORE::eval { local $@; CORE::require strict }) {
  197         308  
  197         3355  
64 197         497461 strict::->import;
65             }
66             }
67              
68             # P.714 29.2.39. flock
69             # in Chapter 29: Functions
70             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
71              
72             # P.863 flock
73             # in Chapter 27: Functions
74             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
75              
76             # P.228 Inlining Constant Functions
77             # in Chapter 6: Subroutines
78             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
79              
80             # P.331 Inlining Constant Functions
81             # in Chapter 7: Subroutines
82             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
83              
84             sub LOCK_SH() {1}
85             sub LOCK_EX() {2}
86             sub LOCK_UN() {8}
87             sub LOCK_NB() {4}
88              
89 0     0   0 sub unimport {}
90             sub Char::Greek::escape_script;
91              
92             # 6.18. Matching Multiple-Byte Characters
93             # in Chapter 6. Pattern Matching
94             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
95             # (and so on)
96              
97             # regexp of character
98             my $qq_char = qr/\\c[\x40-\x5F]|\\?(?:[\x00-\xFF])/oxms;
99             my $q_char = qr/[\x00-\xFF]/oxms;
100              
101             # when this script is main program
102             if ($0 eq __FILE__) {
103              
104             # show usage
105             unless (@ARGV) {
106             die <
107             $0: usage
108              
109             perl $0 Greek_script.pl > Escaped_script.pl.e
110             END
111             }
112              
113             print Char::Greek::escape_script($ARGV[0]);
114             exit 0;
115             }
116              
117             my($package,$filename,$line,$subroutine,$hasargs,$wantarray,$evaltext,$is_require,$hints,$bitmask) = caller 0;
118              
119             # called any package not main
120             if ($package ne 'main') {
121             die <
122             @{[__FILE__]}: escape by manually command '$^X @{[__FILE__]} "$filename" > "@{[__PACKAGE__]}::$filename"'
123             and rewrite "use $package;" to "use @{[__PACKAGE__]}::$package;" of script "$0".
124             END
125             }
126              
127             # P.302 Module Privacy and the Exporter
128             # in Chapter 11: Modules
129             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
130             #
131             # A module can do anything it jolly well pleases when it's used, since use just
132             # calls the ordinary import method for the module, and you can define that
133             # method to do anything you like.
134              
135             # P.406 Module Privacy and the Exporter
136             # in Chapter 11: Modules
137             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
138             #
139             # A module can do anything it jolly well pleases when it's used, since use just
140             # calls the ordinary import method for the module, and you can define that
141             # method to do anything you like.
142              
143             sub import {
144              
145 197 50   197   9094 if (-e("$filename.e")) {
146 197 50       3153 if (exists $ENV{'SJIS_DEBUG'}) {
    50          
147 0         0 unlink "$filename.e";
148             }
149             elsif (-z("$filename.e")) {
150 0         0 unlink "$filename.e";
151             }
152             else {
153              
154             #----------------------------------------------------
155             # older >
156             # newer >>>>>
157             #----------------------------------------------------
158             # Filter >
159             # Source >>>>>
160             # Escape >>> needs re-escape (Source was changed)
161             #
162             # Filter >>>
163             # Source >>>>>
164             # Escape > needs re-escape (Source was changed)
165             #
166             # Filter >>>>>
167             # Source >>>
168             # Escape > needs re-escape (Source was changed)
169             #
170             # Filter >>>>>
171             # Source >
172             # Escape >>> needs re-escape (Filter was changed)
173             #
174             # Filter >
175             # Source >>>
176             # Escape >>>>> executable without re-escape
177             #
178             # Filter >>>
179             # Source >
180             # Escape >>>>> executable without re-escape
181             #----------------------------------------------------
182              
183 197         4000 my $mtime_filter = (stat(__FILE__ ))[9];
184 197         2031 my $mtime_source = (stat($filename ))[9];
185 197         1857 my $mtime_escape = (stat("$filename.e"))[9];
186 197 50 33     2348 if (($mtime_escape < $mtime_source) or ($mtime_escape < $mtime_filter)) {
187 0         0 unlink "$filename.e";
188             }
189             }
190             }
191              
192 197 50       15831 if (not -e("$filename.e")) {
193 0         0 my $fh = gensym();
194              
195 0 0 0     0 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)) {
196             }
197             else {
198 0 0       0 Char::Egreek::_open_a($fh, "$filename.e") or die __FILE__, ": Can't write open file: $filename.e";
199             }
200              
201 0 0       0 if (0) {
202             }
203 0         0 elsif (exists $ENV{'SJIS_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{
224             unless (flock($fh, LOCK_EX | LOCK_NB)) {
225             warn __FILE__, ": Can't immediately write-lock the file: $filename.e";
226             exit;
227             }
228             };
229             }
230             else {
231 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
232             }
233              
234 0         0 CORE::eval q{ truncate($fh, 0) };
235 0 0       0 seek($fh, 0, 0) or die __FILE__, ": Can't seek file: $filename.e";
236              
237 0         0 my $e_script = Char::Greek::escape_script($filename);
238 0         0 print {$fh} $e_script;
  0         0  
239              
240 0         0 my $mode = (stat($filename))[2] & 0777;
241 0         0 chmod $mode, "$filename.e";
242              
243 0 0       0 close($fh) or die __FILE__, ": Can't close file: $filename.e";
244             }
245              
246 197         896 my $fh = gensym();
247 197 50       1399 Char::Egreek::_open_r($fh, "$filename.e") or die __FILE__, ": Can't read open file: $filename.e";
248              
249 197 50       1498 if (0) {
250             }
251 0         0 elsif (exists $ENV{'SJIS_NONBLOCK'}) {
252 0         0 CORE::eval q{
253             unless (flock($fh, LOCK_SH | LOCK_NB)) {
254             warn __FILE__, ": Can't immediately read-lock the file: $filename.e";
255             exit;
256             }
257             };
258             }
259             else {
260 197         12178 CORE::eval q{ flock($fh, LOCK_SH) };
261             }
262              
263 197         821 my @switch = ();
264 197 50       1112 if ($^W) {
265 0         0 push @switch, '-w';
266             }
267              
268             # P.707 29.2.33. exec
269             # in Chapter 29: Functions
270             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
271             #
272             # If there is more than one argument in LIST, or if LIST is an array with more
273             # than one value, the system shell will never be used. This also bypasses any
274             # shell processing of the command. The presence or absence of metacharacters in
275             # the arguments doesn't affect this list-triggered behavior, which makes it the
276             # preferred from in security-conscious programs that do not with to expose
277             # themselves to potential shell escapes.
278             # Environment variable PERL5SHELL(Microsoft ports only) will never be used, too.
279              
280             # P.855 exec
281             # in Chapter 27: Functions
282             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
283             #
284             # If there is more than one argument in LIST, or if LIST is an array with more
285             # than one value, the system shell will never be used. This also bypasses any
286             # shell processing of the command. The presence or absence of metacharacters in
287             # the arguments doesn't affect this list-triggered behavior, which makes it the
288             # preferred from in security-conscious programs that do not wish to expose
289             # themselves to injection attacks via shell escapes.
290             # Environment variable PERL5SHELL(Microsoft ports only) will never be used, too.
291              
292             # P.489 #! and Quoting on Non-Unix Systems
293             # in Chapter 19: The Command-Line Interface
294             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
295              
296             # P.578 #! and Quoting on Non-Unix Systems
297             # in Chapter 17: The Command-Line Interface
298             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
299              
300             # DOS-like system
301 197 50       1542 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
302 0         0 exit Char::Egreek::_systemx(
303             _escapeshellcmd_MSWin32($^X),
304              
305             # -I switch can not treat space included path
306             # (map { '-I' . _escapeshellcmd_MSWin32($_) } @INC),
307 0         0 (map { '-I' . $_ } @INC),
308              
309             @switch,
310             '--',
311 0         0 map { _escapeshellcmd_MSWin32($_) } "$filename.e", @ARGV
312             );
313             }
314              
315             # UNIX-like system
316             else {
317 2167         2981 exit Char::Egreek::_systemx(
318             _escapeshellcmd($^X),
319 197         626 (map { '-I' . _escapeshellcmd($_) } @INC),
320             @switch,
321             '--',
322 197         745 map { _escapeshellcmd($_) } "$filename.e", @ARGV
323             );
324             }
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 0         0 return $word;
335             }
336             }
337              
338             # escape shell command line on UNIX-like system
339             sub _escapeshellcmd {
340 2561     2561   3350 my($word) = @_;
341 2561         8279 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 Char::Greek::escape_script {
354 0     0 0   my($script) = @_;
355 0           my $e_script = '';
356              
357             # read Greek script
358 0           my $fh = gensym();
359 0 0         Char::Egreek::_open_r($fh, $script) or die __FILE__, ": Can't open file: $script";
360 0           local $/ = undef; # slurp mode
361 0           $_ = <$fh>;
362 0 0         close($fh) or die __FILE__, ": Can't close file: $script";
363              
364 0 0         if (/^ use Char::Egreek(?:\s+[0-9\.]*)?\s*; $/oxms) {
365 0           return $_;
366             }
367             else {
368              
369             # #! shebang line
370 0 0         if (s/\A(#!.+?\n)//oms) {
371 0           my $head = $1;
372 0           $head =~ s/\bjperl\b/perl/gi;
373 0           $e_script .= $head;
374             }
375              
376             # DOS-like system header
377 0 0         if (s/\A(\@rem\s*=\s*'.*?'\s*;\s*\n)//oms) {
378 0           my $head = $1;
379 0           $head =~ s/\bjperl\b/perl/gi;
380 0           $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 0         if (s/(.*^#\s*line\s+\d+(?:\s+"(?:$q_char)+?")?\s*\n)//oms) {
392 0           my $head = $1;
393 0           $head =~ s/\bjperl\b/perl/gi;
394 0           $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 0           $e_script .= sprintf("use Char::Egreek '%s.0'; # 'quote' for perl5.6\n", $Char::Greek::VERSION); # require run-time routines version
408              
409             # use Char::Greek version qw(ord reverse getc);
410 0 0         if (s/^ \s* use \s+ Char::Greek \s* ([^;]*) ; \s* \n? $//oxms) {
411              
412             # require version
413 0           my $list = $1;
414 0 0         if ($list =~ s/\A ([0-9]+\.[0-9]+) \.0 \s* //oxms) {
    0          
415 0           my $version = $1;
416 0 0         if ($version ne $Char::Greek::VERSION) {
417 0           my @file = grep -e, map {qq{$_/Char/Greek.pm}} @INC;
  0            
418 0           my %file = map { $_ => 1 } @file;
  0            
419 0 0         if (scalar(keys %file) >= 2) {
420 0           my $file = join "\n", sort keys %file;
421 0           warn <
422             ****************************************************
423             C A U T I O N
424              
425             CONFLICT Char/Greek.pm FILE
426              
427             $file
428             ****************************************************
429              
430             END
431             }
432 0           die "Script $0 expects Char/Greek.pm $version, but @{[__FILE__]} is version $Char::Greek::VERSION\n";
  0            
433             }
434 0           $e_script .= qq{die "Script \$0 expects Char/Egreek.pm $version, but \\\$Char::Egreek::VERSION is \$Char::Egreek::VERSION" if \$Char::Egreek::VERSION ne '$version';\n};
435             }
436             elsif ($list =~ s/\A ([0-9]+(?:\.[0-9]*)) \s* //oxms) {
437 0           my $version = $1;
438 0 0         if ($version > $Char::Greek::VERSION) {
439 0           die "Script $0 required Char/Greek.pm $version, but @{[__FILE__]} is only version $Char::Greek::VERSION\n";
  0            
440             }
441             }
442              
443             # demand ord, reverse, and getc
444 0 0         if ($list !~ /\A \s* \z/oxms) {
445 0           local $@;
446 0           my @list = CORE::eval $list;
447 0           for (@list) {
448 0 0         $Char::Egreek::function_ord = 'Char::Greek::ord' if /\A ord \z/oxms;
449 0 0         $Char::Egreek::function_ord_ = 'Char::Greek::ord_' if /\A ord \z/oxms;
450 0 0         $Char::Egreek::function_reverse = 'Char::Greek::reverse' if /\A reverse \z/oxms;
451 0 0         $Char::Egreek::function_getc = 'Char::Greek::getc' if /\A getc \z/oxms;
452             }
453             }
454             }
455             }
456              
457 0           $e_script .= Char::Greek::escape();
458              
459 0           return $e_script;
460             }
461              
462             1;
463              
464             __END__