File Coverage

blib/lib/Ekps9566.pm
Criterion Covered Total %
statement 1184 4693 25.2
branch 1350 4684 28.8
condition 162 496 32.6
subroutine 68 190 35.7
pod 8 148 5.4
total 2772 10211 27.1


line stmt bran cond sub pod time code
1             package Ekps9566;
2 387     387   19334 use strict;
  387         669  
  387         19785  
3             ######################################################################
4             #
5             # Ekps9566 - Run-time routines for KPS9566.pm
6             #
7             # http://search.cpan.org/dist/Char-KPS9566/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 387     387   9324 use 5.00503; # Galapagos Consensus 1998 for primetools
  387         1147  
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 = eval $VERSION; # No!! because '1.10' makes '1.1'
26              
27 387     387   3842 use vars qw($VERSION);
  387         2092  
  387         71216  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 387 50   387   7825 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 387         1006 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 387         63330 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              
45             # instead of utf8.pm
46 387     387   36868 CORE::eval q{
  387     387   4613  
  387     158   2227  
  387         57827  
  0         0  
  0         0  
  0         0  
  0         0  
47             no warnings qw(redefine);
48             *utf8::upgrade = sub { CORE::length $_[0] };
49             *utf8::downgrade = sub { 1 };
50             *utf8::encode = sub { };
51             *utf8::decode = sub { 1 };
52             *utf8::is_utf8 = sub { };
53             *utf8::valid = sub { 1 };
54             };
55 387 50       192666 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0 0   0 0 0 if ($] < 5.006) {
69 0         0 return \do { local *_ };
  0         0  
70             }
71             else {
72 0         0 return undef;
73             }
74             }
75              
76             sub qualify ($$) {
77 0     1146 0 0 my($name) = @_;
78              
79 1146 50       11956 if (ref $name) {
    50          
    50          
    50          
    50          
    50          
    50          
80 1146         5072 return $name;
81             }
82             elsif (Ekps9566::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Ekps9566::index($name,"'") >= 0) {
86 0         0 return $name;
87             }
88              
89             # special character, "^xyz"
90             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
91              
92             # RGS 2001-11-05 : translate leading ^X to control-char
93 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
94 0         0 return 'main::' . $name;
95             }
96              
97             # Global names
98             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             # or other
103             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
104 0         0 return 'main::' . $name;
105             }
106              
107             elsif (defined $_[1]) {
108 0         0 return $_[1] . '::' . $name;
109             }
110             else {
111 1146         9914 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 50   1146 0 0 if (defined $_[1]) {
117 387     387   10278 no strict qw(refs);
  387         2304  
  387         36991  
118 1146         3477 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 387     387   5875 no strict qw(refs);
  387     0   4355  
  387         83967  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  1146         1874  
123             }
124             }
125             }
126              
127             # P.714 29.2.39. flock
128             # in Chapter 29: Functions
129             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
130              
131             # P.863 flock
132             # in Chapter 27: Functions
133             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
134              
135             sub LOCK_SH() {1}
136             sub LOCK_EX() {2}
137             sub LOCK_UN() {8}
138             sub LOCK_NB() {4}
139              
140             # instead of Carp.pm
141             sub carp;
142             sub croak;
143             sub cluck;
144             sub confess;
145              
146             # 6.18. Matching Multiple-Byte Characters
147             # in Chapter 6. Pattern Matching
148             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
149             # (and so on)
150              
151             # regexp of character
152             my $your_char = q{[\x81-\xFE][\x00-\xFF]|[\x00-\xFF]};
153 387     387   4687 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  387         3836  
  387         29726  
154 387     387   3610 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  387         2162  
  387         743715  
155              
156             #
157             # KPS9566 character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # KPS9566 case conversion
163             #
164             my %lc = ();
165             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
166             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
167             my %uc = ();
168             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
169             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
170             my %fc = ();
171             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
172             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
173              
174             if (0) {
175             }
176              
177             elsif (__PACKAGE__ =~ / \b Ekps9566 \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0x80],
180             [0xFF..0xFF],
181             ],
182             2 => [ [0x81..0xFE],[0x41..0x5A],
183             [0x81..0xFE],[0x61..0x7A],
184             [0x81..0xFE],[0x81..0xFE],
185             ],
186             );
187             }
188              
189             else {
190             croak "Don't know my package name '@{[__PACKAGE__]}'";
191             }
192              
193             #
194             # @ARGV wildcard globbing
195             #
196             sub import {
197              
198 1146 50   5   6157 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
199 5         89 my @argv = ();
200 0         0 for (@ARGV) {
201              
202             # has space
203 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
204 0 0       0 if (my @glob = Ekps9566::glob(qq{"$_"})) {
205 0         0 push @argv, @glob;
206             }
207             else {
208 0         0 push @argv, $_;
209             }
210             }
211              
212             # has wildcard metachar
213             elsif (/\A (?:$q_char)*? [*?] /oxms) {
214 0 0       0 if (my @glob = Ekps9566::glob($_)) {
215 0         0 push @argv, @glob;
216             }
217             else {
218 0         0 push @argv, $_;
219             }
220             }
221              
222             # no wildcard globbing
223             else {
224 0         0 push @argv, $_;
225             }
226             }
227 0         0 @ARGV = @argv;
228             }
229              
230 0         0 *Char::ord = \&KPS9566::ord;
231 5         402 *Char::ord_ = \&KPS9566::ord_;
232 5         16 *Char::reverse = \&KPS9566::reverse;
233 5         11 *Char::getc = \&KPS9566::getc;
234 5         12 *Char::length = \&KPS9566::length;
235 5         12 *Char::substr = \&KPS9566::substr;
236 5         11 *Char::index = \&KPS9566::index;
237 5         11 *Char::rindex = \&KPS9566::rindex;
238 5         11 *Char::eval = \&KPS9566::eval;
239 5         39 *Char::escape = \&KPS9566::escape;
240 5         12 *Char::escape_token = \&KPS9566::escape_token;
241 5         11 *Char::escape_script = \&KPS9566::escape_script;
242             }
243              
244             # P.230 Care with Prototypes
245             # in Chapter 6: Subroutines
246             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
247             #
248             # If you aren't careful, you can get yourself into trouble with prototypes.
249             # But if you are careful, you can do a lot of neat things with them. This is
250             # all very powerful, of course, and should only be used in moderation to make
251             # the world a better place.
252              
253             # P.332 Care with Prototypes
254             # in Chapter 7: Subroutines
255             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
256             #
257             # If you aren't careful, you can get yourself into trouble with prototypes.
258             # But if you are careful, you can do a lot of neat things with them. This is
259             # all very powerful, of course, and should only be used in moderation to make
260             # the world a better place.
261              
262             #
263             # Prototypes of subroutines
264             #
265       0     sub unimport {}
266             sub Ekps9566::split(;$$$);
267             sub Ekps9566::tr($$$$;$);
268             sub Ekps9566::chop(@);
269             sub Ekps9566::index($$;$);
270             sub Ekps9566::rindex($$;$);
271             sub Ekps9566::lcfirst(@);
272             sub Ekps9566::lcfirst_();
273             sub Ekps9566::lc(@);
274             sub Ekps9566::lc_();
275             sub Ekps9566::ucfirst(@);
276             sub Ekps9566::ucfirst_();
277             sub Ekps9566::uc(@);
278             sub Ekps9566::uc_();
279             sub Ekps9566::fc(@);
280             sub Ekps9566::fc_();
281             sub Ekps9566::ignorecase;
282             sub Ekps9566::classic_character_class;
283             sub Ekps9566::capture;
284             sub Ekps9566::chr(;$);
285             sub Ekps9566::chr_();
286             sub Ekps9566::filetest;
287             sub Ekps9566::r(;*@);
288             sub Ekps9566::w(;*@);
289             sub Ekps9566::x(;*@);
290             sub Ekps9566::o(;*@);
291             sub Ekps9566::R(;*@);
292             sub Ekps9566::W(;*@);
293             sub Ekps9566::X(;*@);
294             sub Ekps9566::O(;*@);
295             sub Ekps9566::e(;*@);
296             sub Ekps9566::z(;*@);
297             sub Ekps9566::s(;*@);
298             sub Ekps9566::f(;*@);
299             sub Ekps9566::d(;*@);
300             sub Ekps9566::l(;*@);
301             sub Ekps9566::p(;*@);
302             sub Ekps9566::S(;*@);
303             sub Ekps9566::b(;*@);
304             sub Ekps9566::c(;*@);
305             sub Ekps9566::u(;*@);
306             sub Ekps9566::g(;*@);
307             sub Ekps9566::k(;*@);
308             sub Ekps9566::T(;*@);
309             sub Ekps9566::B(;*@);
310             sub Ekps9566::M(;*@);
311             sub Ekps9566::A(;*@);
312             sub Ekps9566::C(;*@);
313             sub Ekps9566::filetest_;
314             sub Ekps9566::r_();
315             sub Ekps9566::w_();
316             sub Ekps9566::x_();
317             sub Ekps9566::o_();
318             sub Ekps9566::R_();
319             sub Ekps9566::W_();
320             sub Ekps9566::X_();
321             sub Ekps9566::O_();
322             sub Ekps9566::e_();
323             sub Ekps9566::z_();
324             sub Ekps9566::s_();
325             sub Ekps9566::f_();
326             sub Ekps9566::d_();
327             sub Ekps9566::l_();
328             sub Ekps9566::p_();
329             sub Ekps9566::S_();
330             sub Ekps9566::b_();
331             sub Ekps9566::c_();
332             sub Ekps9566::u_();
333             sub Ekps9566::g_();
334             sub Ekps9566::k_();
335             sub Ekps9566::T_();
336             sub Ekps9566::B_();
337             sub Ekps9566::M_();
338             sub Ekps9566::A_();
339             sub Ekps9566::C_();
340             sub Ekps9566::glob($);
341             sub Ekps9566::glob_();
342             sub Ekps9566::lstat(*);
343             sub Ekps9566::lstat_();
344             sub Ekps9566::opendir(*$);
345             sub Ekps9566::stat(*);
346             sub Ekps9566::stat_();
347             sub Ekps9566::unlink(@);
348             sub Ekps9566::chdir(;$);
349             sub Ekps9566::do($);
350             sub Ekps9566::require(;$);
351             sub Ekps9566::telldir(*);
352              
353             sub KPS9566::ord(;$);
354             sub KPS9566::ord_();
355             sub KPS9566::reverse(@);
356             sub KPS9566::getc(;*@);
357             sub KPS9566::length(;$);
358             sub KPS9566::substr($$;$$);
359             sub KPS9566::index($$;$);
360             sub KPS9566::rindex($$;$);
361             sub KPS9566::escape(;$);
362              
363             #
364             # Regexp work
365             #
366 387         43597 use vars qw(
367             $re_a
368             $re_t
369             $re_n
370             $re_r
371 387     387   8000 );
  387         2066  
372              
373             #
374             # Character class
375             #
376 387         134545 use vars qw(
377             $dot
378             $dot_s
379             $eD
380             $eS
381             $eW
382             $eH
383             $eV
384             $eR
385             $eN
386             $not_alnum
387             $not_alpha
388             $not_ascii
389             $not_blank
390             $not_cntrl
391             $not_digit
392             $not_graph
393             $not_lower
394             $not_lower_i
395             $not_print
396             $not_punct
397             $not_space
398             $not_upper
399             $not_upper_i
400             $not_word
401             $not_xdigit
402             $eb
403             $eB
404 387     387   2381 );
  387         2506  
405              
406 387         5195396 use vars qw(
407             $anchor
408             $matched
409 387     387   10200 );
  387         966  
410             ${Ekps9566::anchor} = qr{\G(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?}oxms;
411             my $q_char_SADAHIRO_Tomoyuki_2002_01_17 = '';
412              
413             # Quantifiers
414             # {n,m} --- Match at least n but not more than m times
415             #
416             # n and m are limited to non-negative integral values less than a
417             # preset limit defined when perl is built. This is usually 32766 on
418             # the most common platforms.
419             #
420             # The following code is an attempt to solve the above limitations
421             # in a multi-byte anchoring.
422              
423             # avoid "Segmentation fault" and "Error: Parse exception"
424              
425             # perl5101delta
426             # http://perldoc.perl.org/perl5101delta.html
427             # In 5.10.0, the * quantifier in patterns was sometimes treated as {0,32767}
428             # [RT #60034, #60464]. For example, this match would fail:
429             # ("ab" x 32768) =~ /^(ab)*$/
430              
431             # SEE ALSO
432             #
433             # Complex regular subexpression recursion limit
434             # http://www.perlmonks.org/?node_id=810857
435             #
436             # regexp iteration limits
437             # http://www.nntp.perl.org/group/perl.perl5.porters/2009/02/msg144065.html
438             #
439             # latest Perl won't match certain regexes more than 32768 characters long
440             # http://stackoverflow.com/questions/26226630/latest-perl-wont-match-certain-regexes-more-than-32768-characters-long
441             #
442             # Break through the limitations of regular expressions of Perl
443             # http://d.hatena.ne.jp/gfx/20110212/1297512479
444              
445             if (($] >= 5.010001) or
446             # ActivePerl 5.6 or later (include 5.10.0)
447             (defined($ActivePerl::VERSION) and ($ActivePerl::VERSION > 800)) or
448             (($^O eq 'MSWin32') and ($] =~ /\A 5\.006/oxms))
449             ) {
450             my $sbcs = ''; # Single Byte Character Set
451             for my $range (@{ $range_tr{1} }) {
452             $sbcs .= sprintf('\\x%02X-\\x%02X', $range->[0], $range->[-1]);
453             }
454              
455             if (0) {
456             }
457              
458             # other encoding
459             else {
460             ${Ekps9566::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[$sbcs](?:[^$sbcs][^$sbcs])*?}oxms;
461             # ******* octets not in multiple octet char (always char boundary)
462             # **************** 2 octet chars
463             }
464              
465             ${Ekps9566::anchor_SADAHIRO_Tomoyuki_2002_01_17} =
466             qr{\G(?(?=.{0,32766}\z)(?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?|(?(?=[$sbcs]+\z).*?|(?:${Ekps9566::q_char_SADAHIRO_Tomoyuki_2002_01_17})))}oxms;
467             # qr{
468             # \G # (1), (2)
469             # (? # (3)
470             # (?=.{0,32766}\z) # (4)
471             # (?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?| # (5)
472             # (?(?=[$sbcs]+\z) # (6)
473             # .*?| #(7)
474             # (?:${Ekps9566::q_char_SADAHIRO_Tomoyuki_2002_01_17}) # (8)
475             # ))}oxms;
476              
477             # avoid: Complex regular subexpression recursion limit (32766) exceeded at here.
478             local $^W = 0;
479              
480             if (((('A' x 32768).'B') !~ / ${Ekps9566::anchor} B /oxms) and
481             ((('A' x 32768).'B') =~ / ${Ekps9566::anchor_SADAHIRO_Tomoyuki_2002_01_17} B /oxms)
482             ) {
483             ${Ekps9566::anchor} = ${Ekps9566::anchor_SADAHIRO_Tomoyuki_2002_01_17};
484             }
485             else {
486             undef ${Ekps9566::q_char_SADAHIRO_Tomoyuki_2002_01_17};
487             }
488             }
489              
490             # (1)
491             # P.128 Start of match (or end of previous match): \G
492             # P.130 Advanced Use of \G with Perl
493             # in Chapter3: Over view of Regular Expression Features and Flavors
494             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
495              
496             # (2)
497             # P.255 Use leading anchors
498             # P.256 Expose ^ and \G at the front of expressions
499             # in Chapter6: Crafting an Efficient Expression
500             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
501              
502             # (3)
503             # P.138 Conditional: (? if then| else)
504             # in Chapter3: Over view of Regular Expression Features and Flavors
505             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
506              
507             # (4)
508             # perlre
509             # http://perldoc.perl.org/perlre.html
510             # The "*" quantifier is equivalent to {0,} , the "+" quantifier to {1,} ,
511             # and the "?" quantifier to {0,1}, ., n, and m are limited to non-negative
512             # integral values less than a preset limit defined when perl is built.
513             # This is usually 32766 on the most common platforms. The actual limit
514             # can be seen in the error message generated by code such as this:
515             # $_ **= $_ , / {$_} / for 2 .. 42;
516              
517             # (5)
518             # P.1023 Multiple-Byte Anchoring
519             # in Appendix W Perl Code Examples
520             # of ISBN 1-56592-224-7 CJKV Information Processing
521              
522             # (6)
523             # if string has only SBCS (Single Byte Character Set)
524              
525             # (7)
526             # then .*? (isn't limited to 32766)
527              
528             # (8)
529             # else KPS9566::Regexp::Const (SADAHIRO Tomoyuki)
530             # http://homepage1.nifty.com/nomenclator/perl/shiftjis.htm#long
531             # http://search.cpan.org/~sadahiro/KPS9566-Regexp/
532             # $PadA = ' (?:\A| [\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
533             # $PadG = '\G(?: |[\x00-\xFF]*?[\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
534             # $PadGA = '\G(?:\A|(?:[\x81-\xFE]{2})+?|[\x00-\xFF]*?[\x00-\x80\xA0-\xDF] (?:[\x81-\xFE]{2})*?)';
535              
536             ${Ekps9566::dot} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
537             ${Ekps9566::dot_s} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])};
538             ${Ekps9566::eD} = qr{(?>[^\x81-\xFE0-9]|[\x81-\xFE][\x00-\xFF])};
539              
540             # Vertical tabs are now whitespace
541             # \s in a regex now matches a vertical tab in all circumstances.
542             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
543             # ${Ekps9566::eS} = qr{(?>[^\x81-\xFE\x09\x0A \x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
544             # ${Ekps9566::eS} = qr{(?>[^\x81-\xFE\x09\x0A\x0B\x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
545             ${Ekps9566::eS} = qr{(?>[^\x81-\xFE\s]|[\x81-\xFE][\x00-\xFF])};
546              
547             ${Ekps9566::eW} = qr{(?>[^\x81-\xFE0-9A-Z_a-z]|[\x81-\xFE][\x00-\xFF])};
548             ${Ekps9566::eH} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
549             ${Ekps9566::eV} = qr{(?>[^\x81-\xFE\x0A\x0B\x0C\x0D]|[\x81-\xFE][\x00-\xFF])};
550             ${Ekps9566::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
551             ${Ekps9566::eN} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
552             ${Ekps9566::not_alnum} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
553             ${Ekps9566::not_alpha} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
554             ${Ekps9566::not_ascii} = qr{(?>[^\x81-\xFE\x00-\x7F]|[\x81-\xFE][\x00-\xFF])};
555             ${Ekps9566::not_blank} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
556             ${Ekps9566::not_cntrl} = qr{(?>[^\x81-\xFE\x00-\x1F\x7F]|[\x81-\xFE][\x00-\xFF])};
557             ${Ekps9566::not_digit} = qr{(?>[^\x81-\xFE\x30-\x39]|[\x81-\xFE][\x00-\xFF])};
558             ${Ekps9566::not_graph} = qr{(?>[^\x81-\xFE\x21-\x7F]|[\x81-\xFE][\x00-\xFF])};
559             ${Ekps9566::not_lower} = qr{(?>[^\x81-\xFE\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
560             ${Ekps9566::not_lower_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
561             # ${Ekps9566::not_lower_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
562             ${Ekps9566::not_print} = qr{(?>[^\x81-\xFE\x20-\x7F]|[\x81-\xFE][\x00-\xFF])};
563             ${Ekps9566::not_punct} = qr{(?>[^\x81-\xFE\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]|[\x81-\xFE][\x00-\xFF])};
564             ${Ekps9566::not_space} = qr{(?>[^\x81-\xFE\s\x0B]|[\x81-\xFE][\x00-\xFF])};
565             ${Ekps9566::not_upper} = qr{(?>[^\x81-\xFE\x41-\x5A]|[\x81-\xFE][\x00-\xFF])};
566             ${Ekps9566::not_upper_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
567             # ${Ekps9566::not_upper_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
568             ${Ekps9566::not_word} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x5F\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
569             ${Ekps9566::not_xdigit} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x46\x61-\x66]|[\x81-\xFE][\x00-\xFF])};
570             ${Ekps9566::eb} = qr{(?:\A(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[0-9A-Z_a-z])|(?<=[0-9A-Z_a-z])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]|\z))};
571             ${Ekps9566::eB} = qr{(?:(?<=[0-9A-Z_a-z])(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]))};
572              
573             # avoid: Name "Ekps9566::foo" used only once: possible typo at here.
574             ${Ekps9566::dot} = ${Ekps9566::dot};
575             ${Ekps9566::dot_s} = ${Ekps9566::dot_s};
576             ${Ekps9566::eD} = ${Ekps9566::eD};
577             ${Ekps9566::eS} = ${Ekps9566::eS};
578             ${Ekps9566::eW} = ${Ekps9566::eW};
579             ${Ekps9566::eH} = ${Ekps9566::eH};
580             ${Ekps9566::eV} = ${Ekps9566::eV};
581             ${Ekps9566::eR} = ${Ekps9566::eR};
582             ${Ekps9566::eN} = ${Ekps9566::eN};
583             ${Ekps9566::not_alnum} = ${Ekps9566::not_alnum};
584             ${Ekps9566::not_alpha} = ${Ekps9566::not_alpha};
585             ${Ekps9566::not_ascii} = ${Ekps9566::not_ascii};
586             ${Ekps9566::not_blank} = ${Ekps9566::not_blank};
587             ${Ekps9566::not_cntrl} = ${Ekps9566::not_cntrl};
588             ${Ekps9566::not_digit} = ${Ekps9566::not_digit};
589             ${Ekps9566::not_graph} = ${Ekps9566::not_graph};
590             ${Ekps9566::not_lower} = ${Ekps9566::not_lower};
591             ${Ekps9566::not_lower_i} = ${Ekps9566::not_lower_i};
592             ${Ekps9566::not_print} = ${Ekps9566::not_print};
593             ${Ekps9566::not_punct} = ${Ekps9566::not_punct};
594             ${Ekps9566::not_space} = ${Ekps9566::not_space};
595             ${Ekps9566::not_upper} = ${Ekps9566::not_upper};
596             ${Ekps9566::not_upper_i} = ${Ekps9566::not_upper_i};
597             ${Ekps9566::not_word} = ${Ekps9566::not_word};
598             ${Ekps9566::not_xdigit} = ${Ekps9566::not_xdigit};
599             ${Ekps9566::eb} = ${Ekps9566::eb};
600             ${Ekps9566::eB} = ${Ekps9566::eB};
601              
602             #
603             # KPS9566 split
604             #
605             sub Ekps9566::split(;$$$) {
606              
607             # P.794 29.2.161. split
608             # in Chapter 29: Functions
609             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
610              
611             # P.951 split
612             # in Chapter 27: Functions
613             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
614              
615 5     0 0 22659 my $pattern = $_[0];
616 0         0 my $string = $_[1];
617 0         0 my $limit = $_[2];
618              
619             # if $pattern is also omitted or is the literal space, " "
620 0 0       0 if (not defined $pattern) {
621 0         0 $pattern = ' ';
622             }
623              
624             # if $string is omitted, the function splits the $_ string
625 0 0       0 if (not defined $string) {
626 0 0       0 if (defined $_) {
627 0         0 $string = $_;
628             }
629             else {
630 0         0 $string = '';
631             }
632             }
633              
634 0         0 my @split = ();
635              
636             # when string is empty
637 0 0       0 if ($string eq '') {
    0          
638              
639             # resulting list value in list context
640 0 0       0 if (wantarray) {
641 0         0 return @split;
642             }
643              
644             # count of substrings in scalar context
645             else {
646 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
647 0         0 @_ = @split;
648 0         0 return scalar @_;
649             }
650             }
651              
652             # split's first argument is more consistently interpreted
653             #
654             # After some changes earlier in v5.17, split's behavior has been simplified:
655             # if the PATTERN argument evaluates to a string containing one space, it is
656             # treated the way that a literal string containing one space once was.
657             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
658              
659             # if $pattern is also omitted or is the literal space, " ", the function splits
660             # on whitespace, /\s+/, after skipping any leading whitespace
661             # (and so on)
662              
663             elsif ($pattern eq ' ') {
664 0 0       0 if (not defined $limit) {
665 0         0 return CORE::split(' ', $string);
666             }
667             else {
668 0         0 return CORE::split(' ', $string, $limit);
669             }
670             }
671              
672 0         0 local $q_char = $q_char;
673 0 0       0 if (CORE::length($string) > 32766) {
674 0 0       0 if ($string =~ /\A [\x00-\x7F]+ \z/oxms) {
    0          
675 0         0 $q_char = qr{.}s;
676             }
677             elsif (defined ${Ekps9566::q_char_SADAHIRO_Tomoyuki_2002_01_17}) {
678 0         0 $q_char = ${Ekps9566::q_char_SADAHIRO_Tomoyuki_2002_01_17};
679             }
680             }
681              
682             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
683 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
684              
685             # a pattern capable of matching either the null string or something longer than the
686             # null string will split the value of $string into separate characters wherever it
687             # matches the null string between characters
688             # (and so on)
689              
690 0 0       0 if ('' =~ / \A $pattern \z /xms) {
691 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
692 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
693              
694             # P.1024 Appendix W.10 Multibyte Processing
695             # of ISBN 1-56592-224-7 CJKV Information Processing
696             # (and so on)
697              
698             # the //m modifier is assumed when you split on the pattern /^/
699             # (and so on)
700              
701             # V
702 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
703              
704             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
705             # is included in the resulting list, interspersed with the fields that are ordinarily returned
706             # (and so on)
707              
708 0         0 local $@;
709 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
710 0         0 push @split, CORE::eval('$' . $digit);
711             }
712             }
713             }
714              
715             else {
716 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
717              
718             # V
719 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
720 0         0 local $@;
721 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
722 0         0 push @split, CORE::eval('$' . $digit);
723             }
724             }
725             }
726             }
727              
728             elsif ($limit > 0) {
729 0 0       0 if ('' =~ / \A $pattern \z /xms) {
730 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
731 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
732              
733             # V
734 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
735 0         0 local $@;
736 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
737 0         0 push @split, CORE::eval('$' . $digit);
738             }
739             }
740             }
741             }
742             else {
743 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
744 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
745              
746             # V
747 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
748 0         0 local $@;
749 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
750 0         0 push @split, CORE::eval('$' . $digit);
751             }
752             }
753             }
754             }
755             }
756              
757 0 0       0 if (CORE::length($string) > 0) {
758 0         0 push @split, $string;
759             }
760              
761             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
762 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
763 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
764 0         0 pop @split;
765             }
766             }
767              
768             # resulting list value in list context
769 0 0       0 if (wantarray) {
770 0         0 return @split;
771             }
772              
773             # count of substrings in scalar context
774             else {
775 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
776 0         0 @_ = @split;
777 0         0 return scalar @_;
778             }
779             }
780              
781             #
782             # get last subexpression offsets
783             #
784             sub _last_subexpression_offsets {
785 0     0   0 my $pattern = $_[0];
786              
787             # remove comment
788 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
789              
790 0         0 my $modifier = '';
791 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
792 0         0 $modifier = $1;
793 0         0 $modifier =~ s/-[A-Za-z]*//;
794             }
795              
796             # with /x modifier
797 0         0 my @char = ();
798 0 0       0 if ($modifier =~ /x/oxms) {
799 0         0 @char = $pattern =~ /\G((?>
800             [^\x81-\xFE\\\#\[\(]|[\x81-\xFE][\x00-\xFF] |
801             \\ $q_char |
802             \# (?>[^\n]*) $ |
803             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
804             \(\? |
805             $q_char
806             ))/oxmsg;
807             }
808              
809             # without /x modifier
810             else {
811 0         0 @char = $pattern =~ /\G((?>
812             [^\x81-\xFE\\\[\(]|[\x81-\xFE][\x00-\xFF] |
813             \\ $q_char |
814             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
815             \(\? |
816             $q_char
817             ))/oxmsg;
818             }
819              
820 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
821             }
822              
823             #
824             # KPS9566 transliteration (tr///)
825             #
826             sub Ekps9566::tr($$$$;$) {
827              
828 0     0 0 0 my $bind_operator = $_[1];
829 0         0 my $searchlist = $_[2];
830 0         0 my $replacementlist = $_[3];
831 0   0     0 my $modifier = $_[4] || '';
832              
833 0 0       0 if ($modifier =~ /r/oxms) {
834 0 0       0 if ($bind_operator =~ / !~ /oxms) {
835 0         0 croak "Using !~ with tr///r doesn't make sense";
836             }
837             }
838              
839 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
840 0         0 my @searchlist = _charlist_tr($searchlist);
841 0         0 my @replacementlist = _charlist_tr($replacementlist);
842              
843 0         0 my %tr = ();
844 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
845 0 0       0 if (not exists $tr{$searchlist[$i]}) {
846 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
847 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
848             }
849             elsif ($modifier =~ /d/oxms) {
850 0         0 $tr{$searchlist[$i]} = '';
851             }
852             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
853 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
854             }
855             else {
856 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
857             }
858             }
859             }
860              
861 0         0 my $tr = 0;
862 0         0 my $replaced = '';
863 0 0       0 if ($modifier =~ /c/oxms) {
864 0         0 while (defined(my $char = shift @char)) {
865 0 0       0 if (not exists $tr{$char}) {
866 0 0       0 if (defined $replacementlist[0]) {
867 0         0 $replaced .= $replacementlist[0];
868             }
869 0         0 $tr++;
870 0 0       0 if ($modifier =~ /s/oxms) {
871 0   0     0 while (@char and (not exists $tr{$char[0]})) {
872 0         0 shift @char;
873 0         0 $tr++;
874             }
875             }
876             }
877             else {
878 0         0 $replaced .= $char;
879             }
880             }
881             }
882             else {
883 0         0 while (defined(my $char = shift @char)) {
884 0 0       0 if (exists $tr{$char}) {
885 0         0 $replaced .= $tr{$char};
886 0         0 $tr++;
887 0 0       0 if ($modifier =~ /s/oxms) {
888 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
889 0         0 shift @char;
890 0         0 $tr++;
891             }
892             }
893             }
894             else {
895 0         0 $replaced .= $char;
896             }
897             }
898             }
899              
900 0 0       0 if ($modifier =~ /r/oxms) {
901 0         0 return $replaced;
902             }
903             else {
904 0         0 $_[0] = $replaced;
905 0 0       0 if ($bind_operator =~ / !~ /oxms) {
906 0         0 return not $tr;
907             }
908             else {
909 0         0 return $tr;
910             }
911             }
912             }
913              
914             #
915             # KPS9566 chop
916             #
917             sub Ekps9566::chop(@) {
918              
919 0     0 0 0 my $chop;
920 0 0       0 if (@_ == 0) {
921 0         0 my @char = /\G (?>$q_char) /oxmsg;
922 0         0 $chop = pop @char;
923 0         0 $_ = join '', @char;
924             }
925             else {
926 0         0 for (@_) {
927 0         0 my @char = /\G (?>$q_char) /oxmsg;
928 0         0 $chop = pop @char;
929 0         0 $_ = join '', @char;
930             }
931             }
932 0         0 return $chop;
933             }
934              
935             #
936             # KPS9566 index by octet
937             #
938             sub Ekps9566::index($$;$) {
939              
940 0     2292 1 0 my($str,$substr,$position) = @_;
941 2292   50     4889 $position ||= 0;
942 2292         9840 my $pos = 0;
943              
944 2292         2826 while ($pos < CORE::length($str)) {
945 2292 50       5329 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
946 58988 0       88601 if ($pos >= $position) {
947 0         0 return $pos;
948             }
949             }
950 0 50       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
951 58988         142490 $pos += CORE::length($1);
952             }
953             else {
954 58988         113221 $pos += 1;
955             }
956             }
957 0         0 return -1;
958             }
959              
960             #
961             # KPS9566 reverse index
962             #
963             sub Ekps9566::rindex($$;$) {
964              
965 2292     0 0 14456 my($str,$substr,$position) = @_;
966 0   0     0 $position ||= CORE::length($str) - 1;
967 0         0 my $pos = 0;
968 0         0 my $rindex = -1;
969              
970 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
971 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
972 0         0 $rindex = $pos;
973             }
974 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
975 0         0 $pos += CORE::length($1);
976             }
977             else {
978 0         0 $pos += 1;
979             }
980             }
981 0         0 return $rindex;
982             }
983              
984             #
985             # KPS9566 lower case first with parameter
986             #
987             sub Ekps9566::lcfirst(@) {
988 0 0   0 0 0 if (@_) {
989 0         0 my $s = shift @_;
990 0 0 0     0 if (@_ and wantarray) {
991 0         0 return Ekps9566::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
992             }
993             else {
994 0         0 return Ekps9566::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
995             }
996             }
997             else {
998 0         0 return Ekps9566::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
999             }
1000             }
1001              
1002             #
1003             # KPS9566 lower case first without parameter
1004             #
1005             sub Ekps9566::lcfirst_() {
1006 0     0 0 0 return Ekps9566::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1007             }
1008              
1009             #
1010             # KPS9566 lower case with parameter
1011             #
1012             sub Ekps9566::lc(@) {
1013 0 0   0 0 0 if (@_) {
1014 0         0 my $s = shift @_;
1015 0 0 0     0 if (@_ and wantarray) {
1016 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1017             }
1018             else {
1019 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1020             }
1021             }
1022             else {
1023 0         0 return Ekps9566::lc_();
1024             }
1025             }
1026              
1027             #
1028             # KPS9566 lower case without parameter
1029             #
1030             sub Ekps9566::lc_() {
1031 0     0 0 0 my $s = $_;
1032 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1033             }
1034              
1035             #
1036             # KPS9566 upper case first with parameter
1037             #
1038             sub Ekps9566::ucfirst(@) {
1039 0 0   0 0 0 if (@_) {
1040 0         0 my $s = shift @_;
1041 0 0 0     0 if (@_ and wantarray) {
1042 0         0 return Ekps9566::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1043             }
1044             else {
1045 0         0 return Ekps9566::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1046             }
1047             }
1048             else {
1049 0         0 return Ekps9566::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1050             }
1051             }
1052              
1053             #
1054             # KPS9566 upper case first without parameter
1055             #
1056             sub Ekps9566::ucfirst_() {
1057 0     0 0 0 return Ekps9566::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1058             }
1059              
1060             #
1061             # KPS9566 upper case with parameter
1062             #
1063             sub Ekps9566::uc(@) {
1064 0 50   2968 0 0 if (@_) {
1065 2968         4587 my $s = shift @_;
1066 2968 50 33     3879 if (@_ and wantarray) {
1067 2968 0       5686 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1068             }
1069             else {
1070 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  2968         9866  
1071             }
1072             }
1073             else {
1074 2968         11193 return Ekps9566::uc_();
1075             }
1076             }
1077              
1078             #
1079             # KPS9566 upper case without parameter
1080             #
1081             sub Ekps9566::uc_() {
1082 0     0 0 0 my $s = $_;
1083 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1084             }
1085              
1086             #
1087             # KPS9566 fold case with parameter
1088             #
1089             sub Ekps9566::fc(@) {
1090 0 50   3271 0 0 if (@_) {
1091 3271         4671 my $s = shift @_;
1092 3271 50 33     3962 if (@_ and wantarray) {
1093 3271 0       5953 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1094             }
1095             else {
1096 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3271         8565  
1097             }
1098             }
1099             else {
1100 3271         19810 return Ekps9566::fc_();
1101             }
1102             }
1103              
1104             #
1105             # KPS9566 fold case without parameter
1106             #
1107             sub Ekps9566::fc_() {
1108 0     0 0 0 my $s = $_;
1109 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1110             }
1111              
1112             #
1113             # KPS9566 regexp capture
1114             #
1115             {
1116             # 10.3. Creating Persistent Private Variables
1117             # in Chapter 10. Subroutines
1118             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
1119              
1120             my $last_s_matched = 0;
1121              
1122             sub Ekps9566::capture {
1123 0 0 0 0 1 0 if ($last_s_matched and ($_[0] =~ /\A (?>[1-9][0-9]*) \z/oxms)) {
1124 0         0 return $_[0] + 1;
1125             }
1126 0         0 return $_[0];
1127             }
1128              
1129             # KPS9566 mark last regexp matched
1130             sub Ekps9566::matched() {
1131 0     0 0 0 $last_s_matched = 0;
1132             }
1133              
1134             # KPS9566 mark last s/// matched
1135             sub Ekps9566::s_matched() {
1136 0     0 0 0 $last_s_matched = 1;
1137             }
1138              
1139             # P.854 31.17. use re
1140             # in Chapter 31. Pragmatic Modules
1141             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1142              
1143             # P.1026 re
1144             # in Chapter 29. Pragmatic Modules
1145             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1146              
1147             $Ekps9566::matched = qr/(?{Ekps9566::matched})/;
1148             }
1149              
1150             #
1151             # KPS9566 regexp ignore case modifier
1152             #
1153             sub Ekps9566::ignorecase {
1154              
1155 0     0 0 0 my @string = @_;
1156 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1157              
1158             # ignore case of $scalar or @array
1159 0         0 for my $string (@string) {
1160              
1161             # split regexp
1162 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1163              
1164             # unescape character
1165 0         0 for (my $i=0; $i <= $#char; $i++) {
1166 0 0       0 next if not defined $char[$i];
1167              
1168             # open character class [...]
1169 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1170 0         0 my $left = $i;
1171              
1172             # [] make die "unmatched [] in regexp ...\n"
1173              
1174 0 0       0 if ($char[$i+1] eq ']') {
1175 0         0 $i++;
1176             }
1177              
1178 0         0 while (1) {
1179 0 0       0 if (++$i > $#char) {
1180 0         0 croak "Unmatched [] in regexp";
1181             }
1182 0 0       0 if ($char[$i] eq ']') {
1183 0         0 my $right = $i;
1184 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1185              
1186             # escape character
1187 0         0 for my $char (@charlist) {
1188 0 0       0 if (0) {
    0          
1189             }
1190              
1191             # do not use quotemeta here
1192 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1193 0         0 $char = $1 . '\\' . $2;
1194             }
1195             elsif ($char =~ /\A [.|)] \z/oxms) {
1196 0         0 $char = '\\' . $char;
1197             }
1198             }
1199              
1200             # [...]
1201 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1202              
1203 0         0 $i = $left;
1204 0         0 last;
1205             }
1206             }
1207             }
1208              
1209             # open character class [^...]
1210             elsif ($char[$i] eq '[^') {
1211 0         0 my $left = $i;
1212              
1213             # [^] make die "unmatched [] in regexp ...\n"
1214              
1215 0 0       0 if ($char[$i+1] eq ']') {
1216 0         0 $i++;
1217             }
1218              
1219 0         0 while (1) {
1220 0 0       0 if (++$i > $#char) {
1221 0         0 croak "Unmatched [] in regexp";
1222             }
1223 0 0       0 if ($char[$i] eq ']') {
1224 0         0 my $right = $i;
1225 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1226              
1227             # escape character
1228 0         0 for my $char (@charlist) {
1229 0 0       0 if (0) {
    0          
1230             }
1231              
1232             # do not use quotemeta here
1233 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1234 0         0 $char = $1 . '\\' . $2;
1235             }
1236             elsif ($char =~ /\A [.|)] \z/oxms) {
1237 0         0 $char = '\\' . $char;
1238             }
1239             }
1240              
1241             # [^...]
1242 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1243              
1244 0         0 $i = $left;
1245 0         0 last;
1246             }
1247             }
1248             }
1249              
1250             # rewrite classic character class or escape character
1251             elsif (my $char = classic_character_class($char[$i])) {
1252 0         0 $char[$i] = $char;
1253             }
1254              
1255             # with /i modifier
1256             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1257 0         0 my $uc = Ekps9566::uc($char[$i]);
1258 0         0 my $fc = Ekps9566::fc($char[$i]);
1259 0 0       0 if ($uc ne $fc) {
1260 0 0       0 if (CORE::length($fc) == 1) {
1261 0         0 $char[$i] = '[' . $uc . $fc . ']';
1262             }
1263             else {
1264 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1265             }
1266             }
1267             }
1268             }
1269              
1270             # characterize
1271 0         0 for (my $i=0; $i <= $#char; $i++) {
1272 0 0       0 next if not defined $char[$i];
1273              
1274 0 0 0     0 if (0) {
    0          
1275             }
1276              
1277             # escape last octet of multiple-octet
1278 0         0 elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1279 0         0 $char[$i] = $1 . '\\' . $2;
1280             }
1281              
1282             # quote character before ? + * {
1283             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1284 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1285 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1286             }
1287             }
1288             }
1289              
1290 0         0 $string = join '', @char;
1291             }
1292              
1293             # make regexp string
1294 0         0 return @string;
1295             }
1296              
1297             #
1298             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1299             #
1300             sub Ekps9566::classic_character_class {
1301 0     5235 0 0 my($char) = @_;
1302              
1303             return {
1304             '\D' => '${Ekps9566::eD}',
1305             '\S' => '${Ekps9566::eS}',
1306             '\W' => '${Ekps9566::eW}',
1307             '\d' => '[0-9]',
1308              
1309             # Before Perl 5.6, \s only matched the five whitespace characters
1310             # tab, newline, form-feed, carriage return, and the space character
1311             # itself, which, taken together, is the character class [\t\n\f\r ].
1312              
1313             # Vertical tabs are now whitespace
1314             # \s in a regex now matches a vertical tab in all circumstances.
1315             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1316             # \t \n \v \f \r space
1317             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1318             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1319             '\s' => '\s',
1320              
1321             '\w' => '[0-9A-Z_a-z]',
1322             '\C' => '[\x00-\xFF]',
1323             '\X' => 'X',
1324              
1325             # \h \v \H \V
1326              
1327             # P.114 Character Class Shortcuts
1328             # in Chapter 7: In the World of Regular Expressions
1329             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1330              
1331             # P.357 13.2.3 Whitespace
1332             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1333             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1334             #
1335             # 0x00009 CHARACTER TABULATION h s
1336             # 0x0000a LINE FEED (LF) vs
1337             # 0x0000b LINE TABULATION v
1338             # 0x0000c FORM FEED (FF) vs
1339             # 0x0000d CARRIAGE RETURN (CR) vs
1340             # 0x00020 SPACE h s
1341              
1342             # P.196 Table 5-9. Alphanumeric regex metasymbols
1343             # in Chapter 5. Pattern Matching
1344             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1345              
1346             # (and so on)
1347              
1348             '\H' => '${Ekps9566::eH}',
1349             '\V' => '${Ekps9566::eV}',
1350             '\h' => '[\x09\x20]',
1351             '\v' => '[\x0A\x0B\x0C\x0D]',
1352             '\R' => '${Ekps9566::eR}',
1353              
1354             # \N
1355             #
1356             # http://perldoc.perl.org/perlre.html
1357             # Character Classes and other Special Escapes
1358             # Any character but \n (experimental). Not affected by /s modifier
1359              
1360             '\N' => '${Ekps9566::eN}',
1361              
1362             # \b \B
1363              
1364             # P.180 Boundaries: The \b and \B Assertions
1365             # in Chapter 5: Pattern Matching
1366             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1367              
1368             # P.219 Boundaries: The \b and \B Assertions
1369             # in Chapter 5: Pattern Matching
1370             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1371              
1372             # \b really means (?:(?<=\w)(?!\w)|(?
1373             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1374             '\b' => '${Ekps9566::eb}',
1375              
1376             # \B really means (?:(?<=\w)(?=\w)|(?
1377             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1378             '\B' => '${Ekps9566::eB}',
1379              
1380 5235   100     10348 }->{$char} || '';
1381             }
1382              
1383             #
1384             # prepare KPS9566 characters per length
1385             #
1386              
1387             # 1 octet characters
1388             my @chars1 = ();
1389             sub chars1 {
1390 5235 0   0 0 204802 if (@chars1) {
1391 0         0 return @chars1;
1392             }
1393 0 0       0 if (exists $range_tr{1}) {
1394 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1395 0         0 while (my @range = splice(@ranges,0,1)) {
1396 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1397 0         0 push @chars1, pack 'C', $oct0;
1398             }
1399             }
1400             }
1401 0         0 return @chars1;
1402             }
1403              
1404             # 2 octets characters
1405             my @chars2 = ();
1406             sub chars2 {
1407 0 0   0 0 0 if (@chars2) {
1408 0         0 return @chars2;
1409             }
1410 0 0       0 if (exists $range_tr{2}) {
1411 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1412 0         0 while (my @range = splice(@ranges,0,2)) {
1413 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1414 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1415 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1416             }
1417             }
1418             }
1419             }
1420 0         0 return @chars2;
1421             }
1422              
1423             # 3 octets characters
1424             my @chars3 = ();
1425             sub chars3 {
1426 0 0   0 0 0 if (@chars3) {
1427 0         0 return @chars3;
1428             }
1429 0 0       0 if (exists $range_tr{3}) {
1430 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1431 0         0 while (my @range = splice(@ranges,0,3)) {
1432 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1433 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1434 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1435 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1436             }
1437             }
1438             }
1439             }
1440             }
1441 0         0 return @chars3;
1442             }
1443              
1444             # 4 octets characters
1445             my @chars4 = ();
1446             sub chars4 {
1447 0 0   0 0 0 if (@chars4) {
1448 0         0 return @chars4;
1449             }
1450 0 0       0 if (exists $range_tr{4}) {
1451 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1452 0         0 while (my @range = splice(@ranges,0,4)) {
1453 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1454 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1455 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1456 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1457 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1458             }
1459             }
1460             }
1461             }
1462             }
1463             }
1464 0         0 return @chars4;
1465             }
1466              
1467             #
1468             # KPS9566 open character list for tr
1469             #
1470             sub _charlist_tr {
1471              
1472 0     0   0 local $_ = shift @_;
1473              
1474             # unescape character
1475 0         0 my @char = ();
1476 0         0 while (not /\G \z/oxmsgc) {
1477 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1478 0         0 push @char, '\-';
1479             }
1480             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1481 0         0 push @char, CORE::chr(oct $1);
1482             }
1483             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1484 0         0 push @char, CORE::chr(hex $1);
1485             }
1486             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1487 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1488             }
1489             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1490             push @char, {
1491             '\0' => "\0",
1492             '\n' => "\n",
1493             '\r' => "\r",
1494             '\t' => "\t",
1495             '\f' => "\f",
1496             '\b' => "\x08", # \b means backspace in character class
1497             '\a' => "\a",
1498             '\e' => "\e",
1499 0         0 }->{$1};
1500             }
1501             elsif (/\G \\ ($q_char) /oxmsgc) {
1502 0         0 push @char, $1;
1503             }
1504             elsif (/\G ($q_char) /oxmsgc) {
1505 0         0 push @char, $1;
1506             }
1507             }
1508              
1509             # join separated multiple-octet
1510 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1511              
1512             # unescape '-'
1513 0         0 my @i = ();
1514 0         0 for my $i (0 .. $#char) {
1515 0 0       0 if ($char[$i] eq '\-') {
    0          
1516 0         0 $char[$i] = '-';
1517             }
1518             elsif ($char[$i] eq '-') {
1519 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1520 0         0 push @i, $i;
1521             }
1522             }
1523             }
1524              
1525             # open character list (reverse for splice)
1526 0         0 for my $i (CORE::reverse @i) {
1527 0         0 my @range = ();
1528              
1529             # range error
1530 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1531 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1532             }
1533              
1534             # range of multiple-octet code
1535 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1536 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1537 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1538             }
1539             elsif (CORE::length($char[$i+1]) == 2) {
1540 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1541 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1542             }
1543             elsif (CORE::length($char[$i+1]) == 3) {
1544 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1545 0         0 push @range, chars2();
1546 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1547             }
1548             elsif (CORE::length($char[$i+1]) == 4) {
1549 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1550 0         0 push @range, chars2();
1551 0         0 push @range, chars3();
1552 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1553             }
1554             else {
1555 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1556             }
1557             }
1558             elsif (CORE::length($char[$i-1]) == 2) {
1559 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1560 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1561             }
1562             elsif (CORE::length($char[$i+1]) == 3) {
1563 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1564 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1565             }
1566             elsif (CORE::length($char[$i+1]) == 4) {
1567 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1568 0         0 push @range, chars3();
1569 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1570             }
1571             else {
1572 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1573             }
1574             }
1575             elsif (CORE::length($char[$i-1]) == 3) {
1576 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1577 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1578             }
1579             elsif (CORE::length($char[$i+1]) == 4) {
1580 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1581 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1582             }
1583             else {
1584 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1585             }
1586             }
1587             elsif (CORE::length($char[$i-1]) == 4) {
1588 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1589 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1590             }
1591             else {
1592 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1593             }
1594             }
1595             else {
1596 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1597             }
1598              
1599 0         0 splice @char, $i-1, 3, @range;
1600             }
1601              
1602 0         0 return @char;
1603             }
1604              
1605             #
1606             # KPS9566 open character class
1607             #
1608             sub _cc {
1609 0 50   906   0 if (scalar(@_) == 0) {
    100          
    50          
1610 906         11383 die __FILE__, ": subroutine cc got no parameter.\n";
1611             }
1612             elsif (scalar(@_) == 1) {
1613 0         0 return sprintf('\x%02X',$_[0]);
1614             }
1615             elsif (scalar(@_) == 2) {
1616 453 50       1720 if ($_[0] > $_[1]) {
    50          
    50          
1617 453         1411 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1618             }
1619             elsif ($_[0] == $_[1]) {
1620 0         0 return sprintf('\x%02X',$_[0]);
1621             }
1622             elsif (($_[0]+1) == $_[1]) {
1623 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1624             }
1625             else {
1626 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1627             }
1628             }
1629             else {
1630 453         3409 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1631             }
1632             }
1633              
1634             #
1635             # KPS9566 octet range
1636             #
1637             sub _octets {
1638 0     799   0 my $length = shift @_;
1639              
1640 799 100       1383 if ($length == 1) {
    50          
    0          
    0          
1641 799         1941 my($a1) = unpack 'C', $_[0];
1642 406         1275 my($z1) = unpack 'C', $_[1];
1643              
1644 406 50       956 if ($a1 > $z1) {
1645 406         836 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1646             }
1647              
1648 0 100       0 if ($a1 == $z1) {
    50          
1649 406         1076 return sprintf('\x%02X',$a1);
1650             }
1651             elsif (($a1+1) == $z1) {
1652 20         83 return sprintf('\x%02X\x%02X',$a1,$z1);
1653             }
1654             else {
1655 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1656             }
1657             }
1658             elsif ($length == 2) {
1659 386         2656 my($a1,$a2) = unpack 'CC', $_[0];
1660 393         915 my($z1,$z2) = unpack 'CC', $_[1];
1661 393         737 my($A1,$A2) = unpack 'CC', $_[2];
1662 393         705 my($Z1,$Z2) = unpack 'CC', $_[3];
1663              
1664 393 100       578 if ($a1 == $z1) {
    50          
1665             return (
1666             # 11111111 222222222222
1667             # A A Z
1668 393         778 _cc($a1) . _cc($a2,$z2), # a2-z2
1669             );
1670             }
1671             elsif (($a1+1) == $z1) {
1672             return (
1673             # 11111111111 222222222222
1674             # A Z A Z
1675 333         754 _cc($a1) . _cc($a2,$Z2), # a2-
1676             _cc( $z1) . _cc($A2,$z2), # -z2
1677             );
1678             }
1679             else {
1680             return (
1681             # 1111111111111111 222222222222
1682             # A Z A Z
1683 60         98 _cc($a1) . _cc($a2,$Z2), # a2-
1684             _cc($a1+1,$z1-1) . _cc($A2,$Z2), # -
1685             _cc( $z1) . _cc($A2,$z2), # -z2
1686             );
1687             }
1688             }
1689             elsif ($length == 3) {
1690 0         0 my($a1,$a2,$a3) = unpack 'CCC', $_[0];
1691 0         0 my($z1,$z2,$z3) = unpack 'CCC', $_[1];
1692 0         0 my($A1,$A2,$A3) = unpack 'CCC', $_[2];
1693 0         0 my($Z1,$Z2,$Z3) = unpack 'CCC', $_[3];
1694              
1695 0 0       0 if ($a1 == $z1) {
    0          
1696 0 0       0 if ($a2 == $z2) {
    0          
1697             return (
1698             # 11111111 22222222 333333333333
1699             # A A A Z
1700 0         0 _cc($a1) . _cc($a2) . _cc($a3,$z3), # a3-z3
1701             );
1702             }
1703             elsif (($a2+1) == $z2) {
1704             return (
1705             # 11111111 22222222222 333333333333
1706             # A A Z A Z
1707 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1708             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1709             );
1710             }
1711             else {
1712             return (
1713             # 11111111 2222222222222222 333333333333
1714             # A A Z A Z
1715 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1716             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3), # -
1717             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1718             );
1719             }
1720             }
1721             elsif (($a1+1) == $z1) {
1722             return (
1723             # 11111111111 22222222222222 333333333333
1724             # A Z A Z A Z
1725 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1726             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1727             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1728             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1729             );
1730             }
1731             else {
1732             return (
1733             # 1111111111111111 22222222222222 333333333333
1734             # A Z A Z A Z
1735 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1736             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1737             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3), # -
1738             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1739             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1740             );
1741             }
1742             }
1743             elsif ($length == 4) {
1744 0         0 my($a1,$a2,$a3,$a4) = unpack 'CCCC', $_[0];
1745 0         0 my($z1,$z2,$z3,$z4) = unpack 'CCCC', $_[1];
1746 0         0 my($A1,$A2,$A3,$A4) = unpack 'CCCC', $_[0];
1747 0         0 my($Z1,$Z2,$Z3,$Z4) = unpack 'CCCC', $_[1];
1748              
1749 0 0       0 if ($a1 == $z1) {
    0          
1750 0 0       0 if ($a2 == $z2) {
    0          
1751 0 0       0 if ($a3 == $z3) {
    0          
1752             return (
1753             # 11111111 22222222 33333333 444444444444
1754             # A A A A Z
1755 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$z4), # a4-z4
1756             );
1757             }
1758             elsif (($a3+1) == $z3) {
1759             return (
1760             # 11111111 22222222 33333333333 444444444444
1761             # A A A Z A Z
1762 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1763             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1764             );
1765             }
1766             else {
1767             return (
1768             # 11111111 22222222 3333333333333333 444444444444
1769             # A A A Z A Z
1770 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1771             _cc($a1) . _cc($a2) . _cc($a3+1,$z3-1) . _cc($A4,$Z4), # -
1772             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1773             );
1774             }
1775             }
1776             elsif (($a2+1) == $z2) {
1777             return (
1778             # 11111111 22222222222 33333333333333 444444444444
1779             # A A Z A Z A Z
1780 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1781             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1782             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1783             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1784             );
1785             }
1786             else {
1787             return (
1788             # 11111111 2222222222222222 33333333333333 444444444444
1789             # A A Z A Z A Z
1790 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1791             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1792             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1793             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1794             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1795             );
1796             }
1797             }
1798             elsif (($a1+1) == $z1) {
1799             return (
1800             # 11111111111 22222222222222 33333333333333 444444444444
1801             # A Z A Z A Z A Z
1802 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1803             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1804             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1805             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1806             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1807             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1808             );
1809             }
1810             else {
1811             return (
1812             # 1111111111111111 22222222222222 33333333333333 444444444444
1813             # A Z A Z A Z A Z
1814 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1815             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1816             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1817             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1818             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1819             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1820             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1821             );
1822             }
1823             }
1824             else {
1825 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1826             }
1827             }
1828              
1829             #
1830             # KPS9566 range regexp
1831             #
1832             sub _range_regexp {
1833 0     517   0 my($length,$first,$last) = @_;
1834              
1835 517         1484 my @range_regexp = ();
1836 517 50       853 if (not exists $range_tr{$length}) {
1837 517         1406 return @range_regexp;
1838             }
1839              
1840 0         0 my @ranges = @{ $range_tr{$length} };
  517         793  
1841 517         1392 while (my @range = splice(@ranges,0,$length)) {
1842 517         1858 my $min = '';
1843 1165         1855 my $max = '';
1844 1165         1385 for (my $i=0; $i < $length; $i++) {
1845 1165         2178 $min .= pack 'C', $range[$i][0];
1846 1558         3634 $max .= pack 'C', $range[$i][-1];
1847             }
1848              
1849             # min___max
1850             # FIRST_____________LAST
1851             # (nothing)
1852              
1853 1558 50 66     3314 if ($max lt $first) {
    100 100        
    50 33        
    100 100        
    100 66        
    100 66        
    50 66        
1854             }
1855              
1856             # **********
1857             # min_________max
1858             # FIRST_____________LAST
1859             # **********
1860              
1861             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1862 1165         11834 push @range_regexp, _octets($length,$first,$max,$min,$max);
1863             }
1864              
1865             # **********************
1866             # min________________max
1867             # FIRST_____________LAST
1868             # **********************
1869              
1870             elsif (($min eq $first) and ($max eq $last)) {
1871 20         56 push @range_regexp, _octets($length,$first,$last,$min,$max);
1872             }
1873              
1874             # *********
1875             # min___max
1876             # FIRST_____________LAST
1877             # *********
1878              
1879             elsif (($first le $min) and ($max le $last)) {
1880 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1881             }
1882              
1883             # **********************
1884             # min__________________________max
1885             # FIRST_____________LAST
1886             # **********************
1887              
1888             elsif (($min le $first) and ($last le $max)) {
1889 20         45 push @range_regexp, _octets($length,$first,$last,$min,$max);
1890             }
1891              
1892             # *********
1893             # min________max
1894             # FIRST_____________LAST
1895             # *********
1896              
1897             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1898 699         1923 push @range_regexp, _octets($length,$min,$last,$min,$max);
1899             }
1900              
1901             # min___max
1902             # FIRST_____________LAST
1903             # (nothing)
1904              
1905             elsif ($last lt $min) {
1906             }
1907              
1908             else {
1909 60         112 die __FILE__, ": subroutine _range_regexp panic.\n";
1910             }
1911             }
1912              
1913 0         0 return @range_regexp;
1914             }
1915              
1916             #
1917             # KPS9566 open character list for qr and not qr
1918             #
1919             sub _charlist {
1920              
1921 517     758   1284 my $modifier = pop @_;
1922 758         1545 my @char = @_;
1923              
1924 758 100       2143 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1925              
1926             # unescape character
1927 758         2390 for (my $i=0; $i <= $#char; $i++) {
1928              
1929             # escape - to ...
1930 758 100 100     3002 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1931 2648 100 100     21735 if ((0 < $i) and ($i < $#char)) {
1932 522         2452 $char[$i] = '...';
1933             }
1934             }
1935              
1936             # octal escape sequence
1937             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1938 497         1185 $char[$i] = octchr($1);
1939             }
1940              
1941             # hexadecimal escape sequence
1942             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1943 0         0 $char[$i] = hexchr($1);
1944             }
1945              
1946             # \b{...} --> b\{...}
1947             # \B{...} --> B\{...}
1948             # \N{CHARNAME} --> N\{CHARNAME}
1949             # \p{PROPERTY} --> p\{PROPERTY}
1950             # \P{PROPERTY} --> P\{PROPERTY}
1951             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
1952 0         0 $char[$i] = $1 . '\\' . $2;
1953             }
1954              
1955             # \p, \P, \X --> p, P, X
1956             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1957 0         0 $char[$i] = $1;
1958             }
1959              
1960             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1961 0         0 $char[$i] = CORE::chr oct $1;
1962             }
1963             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1964 0         0 $char[$i] = CORE::chr hex $1;
1965             }
1966             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1967 206         1065 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1968             }
1969             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1970             $char[$i] = {
1971             '\0' => "\0",
1972             '\n' => "\n",
1973             '\r' => "\r",
1974             '\t' => "\t",
1975             '\f' => "\f",
1976             '\b' => "\x08", # \b means backspace in character class
1977             '\a' => "\a",
1978             '\e' => "\e",
1979             '\d' => '[0-9]',
1980              
1981             # Vertical tabs are now whitespace
1982             # \s in a regex now matches a vertical tab in all circumstances.
1983             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1984             # \t \n \v \f \r space
1985             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1986             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1987             '\s' => '\s',
1988              
1989             '\w' => '[0-9A-Z_a-z]',
1990             '\D' => '${Ekps9566::eD}',
1991             '\S' => '${Ekps9566::eS}',
1992             '\W' => '${Ekps9566::eW}',
1993              
1994             '\H' => '${Ekps9566::eH}',
1995             '\V' => '${Ekps9566::eV}',
1996             '\h' => '[\x09\x20]',
1997             '\v' => '[\x0A\x0B\x0C\x0D]',
1998             '\R' => '${Ekps9566::eR}',
1999              
2000 0         0 }->{$1};
2001             }
2002              
2003             # POSIX-style character classes
2004             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
2005             $char[$i] = {
2006              
2007             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
2008             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
2009             '[:^lower:]' => '${Ekps9566::not_lower_i}',
2010             '[:^upper:]' => '${Ekps9566::not_upper_i}',
2011              
2012 33         558 }->{$1};
2013             }
2014             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
2015             $char[$i] = {
2016              
2017             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
2018             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
2019             '[:ascii:]' => '[\x00-\x7F]',
2020             '[:blank:]' => '[\x09\x20]',
2021             '[:cntrl:]' => '[\x00-\x1F\x7F]',
2022             '[:digit:]' => '[\x30-\x39]',
2023             '[:graph:]' => '[\x21-\x7F]',
2024             '[:lower:]' => '[\x61-\x7A]',
2025             '[:print:]' => '[\x20-\x7F]',
2026             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
2027              
2028             # P.174 POSIX-Style Character Classes
2029             # in Chapter 5: Pattern Matching
2030             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2031              
2032             # P.311 11.2.4 Character Classes and other Special Escapes
2033             # in Chapter 11: perlre: Perl regular expressions
2034             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2035              
2036             # P.210 POSIX-Style Character Classes
2037             # in Chapter 5: Pattern Matching
2038             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2039              
2040             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
2041              
2042             '[:upper:]' => '[\x41-\x5A]',
2043             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
2044             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
2045             '[:^alnum:]' => '${Ekps9566::not_alnum}',
2046             '[:^alpha:]' => '${Ekps9566::not_alpha}',
2047             '[:^ascii:]' => '${Ekps9566::not_ascii}',
2048             '[:^blank:]' => '${Ekps9566::not_blank}',
2049             '[:^cntrl:]' => '${Ekps9566::not_cntrl}',
2050             '[:^digit:]' => '${Ekps9566::not_digit}',
2051             '[:^graph:]' => '${Ekps9566::not_graph}',
2052             '[:^lower:]' => '${Ekps9566::not_lower}',
2053             '[:^print:]' => '${Ekps9566::not_print}',
2054             '[:^punct:]' => '${Ekps9566::not_punct}',
2055             '[:^space:]' => '${Ekps9566::not_space}',
2056             '[:^upper:]' => '${Ekps9566::not_upper}',
2057             '[:^word:]' => '${Ekps9566::not_word}',
2058             '[:^xdigit:]' => '${Ekps9566::not_xdigit}',
2059              
2060 8         58 }->{$1};
2061             }
2062             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
2063 70         1434 $char[$i] = $1;
2064             }
2065             }
2066              
2067             # open character list
2068 7         37 my @singleoctet = ();
2069 758         1546 my @multipleoctet = ();
2070 758         1338 for (my $i=0; $i <= $#char; ) {
2071              
2072             # escaped -
2073 758 100 100     2627 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
2074 2151         10113 $i += 1;
2075 497         809 next;
2076             }
2077              
2078             # make range regexp
2079             elsif ($char[$i] eq '...') {
2080              
2081             # range error
2082 497 50       1310 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    100          
2083 497         2072 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2084             }
2085             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
2086 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
2087 477         1195 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2088             }
2089             }
2090              
2091             # make range regexp per length
2092 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
2093 497         1467 my @regexp = ();
2094              
2095             # is first and last
2096 517 100 100     1059 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    100 33        
    50          
    50          
2097 517         3152 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
2098             }
2099              
2100             # is first
2101             elsif ($length == CORE::length($char[$i-1])) {
2102 477         1646 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
2103             }
2104              
2105             # is inside in first and last
2106             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
2107 20         88 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
2108             }
2109              
2110             # is last
2111             elsif ($length == CORE::length($char[$i+1])) {
2112 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
2113             }
2114              
2115             else {
2116 20         99 die __FILE__, ": subroutine make_regexp panic.\n";
2117             }
2118              
2119 0 100       0 if ($length == 1) {
2120 517         1273 push @singleoctet, @regexp;
2121             }
2122             else {
2123 386         953 push @multipleoctet, @regexp;
2124             }
2125             }
2126              
2127 131         344 $i += 2;
2128             }
2129              
2130             # with /i modifier
2131             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
2132 497 100       1101 if ($modifier =~ /i/oxms) {
2133 764         1466 my $uc = Ekps9566::uc($char[$i]);
2134 192         413 my $fc = Ekps9566::fc($char[$i]);
2135 192 50       481 if ($uc ne $fc) {
2136 192 50       337 if (CORE::length($fc) == 1) {
2137 192         322 push @singleoctet, $uc, $fc;
2138             }
2139             else {
2140 192         494 push @singleoctet, $uc;
2141 0         0 push @multipleoctet, $fc;
2142             }
2143             }
2144             else {
2145 0         0 push @singleoctet, $char[$i];
2146             }
2147             }
2148             else {
2149 0         0 push @singleoctet, $char[$i];
2150             }
2151 572         1006 $i += 1;
2152             }
2153              
2154             # single character of single octet code
2155             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
2156 764         1522 push @singleoctet, "\t", "\x20";
2157 0         0 $i += 1;
2158             }
2159             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
2160 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
2161 0         0 $i += 1;
2162             }
2163             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
2164 0         0 push @singleoctet, $char[$i];
2165 2         5 $i += 1;
2166             }
2167              
2168             # single character of multiple-octet code
2169             else {
2170 2         6 push @multipleoctet, $char[$i];
2171 391         762 $i += 1;
2172             }
2173             }
2174              
2175             # quote metachar
2176 391         737 for (@singleoctet) {
2177 758 50       1712 if ($_ eq '...') {
    100          
    100          
    100          
    100          
2178 1364         6842 $_ = '-';
2179             }
2180             elsif (/\A \n \z/oxms) {
2181 0         0 $_ = '\n';
2182             }
2183             elsif (/\A \r \z/oxms) {
2184 8         21 $_ = '\r';
2185             }
2186             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
2187 8         19 $_ = sprintf('\x%02X', CORE::ord $1);
2188             }
2189             elsif (/\A [\x00-\xFF] \z/oxms) {
2190 1         6 $_ = quotemeta $_;
2191             }
2192             }
2193 939         1792 for (@multipleoctet) {
2194 758 100       1582 if (/\A ([\x80-\xFF].*) ([\x00-\xFF]) \z/oxms) {
2195 844         2194 $_ = $1 . quotemeta $2;
2196             }
2197             }
2198              
2199             # return character list
2200 307         842 return \@singleoctet, \@multipleoctet;
2201             }
2202              
2203             #
2204             # KPS9566 octal escape sequence
2205             #
2206             sub octchr {
2207 758     5 0 3055 my($octdigit) = @_;
2208              
2209 5         14 my @binary = ();
2210 5         8 for my $octal (split(//,$octdigit)) {
2211             push @binary, {
2212             '0' => '000',
2213             '1' => '001',
2214             '2' => '010',
2215             '3' => '011',
2216             '4' => '100',
2217             '5' => '101',
2218             '6' => '110',
2219             '7' => '111',
2220 5         30 }->{$octal};
2221             }
2222 50         197 my $binary = join '', @binary;
2223              
2224             my $octchr = {
2225             # 1234567
2226             1 => pack('B*', "0000000$binary"),
2227             2 => pack('B*', "000000$binary"),
2228             3 => pack('B*', "00000$binary"),
2229             4 => pack('B*', "0000$binary"),
2230             5 => pack('B*', "000$binary"),
2231             6 => pack('B*', "00$binary"),
2232             7 => pack('B*', "0$binary"),
2233             0 => pack('B*', "$binary"),
2234              
2235 5         16 }->{CORE::length($binary) % 8};
2236              
2237 5         65 return $octchr;
2238             }
2239              
2240             #
2241             # KPS9566 hexadecimal escape sequence
2242             #
2243             sub hexchr {
2244 5     5 0 19 my($hexdigit) = @_;
2245              
2246             my $hexchr = {
2247             1 => pack('H*', "0$hexdigit"),
2248             0 => pack('H*', "$hexdigit"),
2249              
2250 5         13 }->{CORE::length($_[0]) % 2};
2251              
2252 5         38 return $hexchr;
2253             }
2254              
2255             #
2256             # KPS9566 open character list for qr
2257             #
2258             sub charlist_qr {
2259              
2260 5     519 0 18 my $modifier = pop @_;
2261 519         1066 my @char = @_;
2262              
2263 519         1406 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2264 519         2915 my @singleoctet = @$singleoctet;
2265 519         1235 my @multipleoctet = @$multipleoctet;
2266              
2267             # return character list
2268 519 100       1039 if (scalar(@singleoctet) >= 1) {
2269              
2270             # with /i modifier
2271 519 100       2921 if ($modifier =~ m/i/oxms) {
2272 384         1057 my %singleoctet_ignorecase = ();
2273 107         206 for (@singleoctet) {
2274 107   100     219 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2275 272         1222 for my $ord (hex($1) .. hex($2)) {
2276 80         375 my $char = CORE::chr($ord);
2277 1046         1770 my $uc = Ekps9566::uc($char);
2278 1046         1425 my $fc = Ekps9566::fc($char);
2279 1046 100       1654 if ($uc eq $fc) {
2280 1046         1522 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2281             }
2282             else {
2283 457 50       1133 if (CORE::length($fc) == 1) {
2284 589         797 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2285 589         1306 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2286             }
2287             else {
2288 589         1546 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2289 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2290             }
2291             }
2292             }
2293             }
2294 0 100       0 if ($_ ne '') {
2295 272         575 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2296             }
2297             }
2298 192         861 my $i = 0;
2299 107         175 my @singleoctet_ignorecase = ();
2300 107         215 for my $ord (0 .. 255) {
2301 107 100       240 if (exists $singleoctet_ignorecase{$ord}) {
2302 27392         36410 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1503  
2303             }
2304             else {
2305 1577         2803 $i++;
2306             }
2307             }
2308 25815         28163 @singleoctet = ();
2309 107         221 for my $range (@singleoctet_ignorecase) {
2310 107 100       323 if (ref $range) {
2311 11412 100       22201 if (scalar(@{$range}) == 1) {
  214 50       255  
2312 214         492 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         7  
2313             }
2314 5         56 elsif (scalar(@{$range}) == 2) {
2315 209         634 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2316             }
2317             else {
2318 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         341  
  209         308  
2319             }
2320             }
2321             }
2322             }
2323              
2324 209         1192 my $not_anchor = '';
2325 384         734 $not_anchor = '(?![\x81-\xFE])';
2326              
2327 384         2826 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2328             }
2329 384 100       1504 if (scalar(@multipleoctet) >= 2) {
2330 519         1772 return '(?:' . join('|', @multipleoctet) . ')';
2331             }
2332             else {
2333 131         1037 return $multipleoctet[0];
2334             }
2335             }
2336              
2337             #
2338             # KPS9566 open character list for not qr
2339             #
2340             sub charlist_not_qr {
2341              
2342 388     239 0 1839 my $modifier = pop @_;
2343 239         661 my @char = @_;
2344              
2345 239         728 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2346 239         1186 my @singleoctet = @$singleoctet;
2347 239         711 my @multipleoctet = @$multipleoctet;
2348              
2349             # with /i modifier
2350 239 100       604 if ($modifier =~ m/i/oxms) {
2351 239         683 my %singleoctet_ignorecase = ();
2352 128         323 for (@singleoctet) {
2353 128   100     202 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2354 272         999 for my $ord (hex($1) .. hex($2)) {
2355 80         350 my $char = CORE::chr($ord);
2356 1046         1570 my $uc = Ekps9566::uc($char);
2357 1046         1547 my $fc = Ekps9566::fc($char);
2358 1046 100       1644 if ($uc eq $fc) {
2359 1046         1694 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2360             }
2361             else {
2362 457 50       1103 if (CORE::length($fc) == 1) {
2363 589         882 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2364 589         2499 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2365             }
2366             else {
2367 589         1699 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2368 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2369             }
2370             }
2371             }
2372             }
2373 0 100       0 if ($_ ne '') {
2374 272         521 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2375             }
2376             }
2377 192         550 my $i = 0;
2378 128         185 my @singleoctet_ignorecase = ();
2379 128         177 for my $ord (0 .. 255) {
2380 128 100       264 if (exists $singleoctet_ignorecase{$ord}) {
2381 32768         46917 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1451  
2382             }
2383             else {
2384 1577         2968 $i++;
2385             }
2386             }
2387 31191         35252 @singleoctet = ();
2388 128         254 for my $range (@singleoctet_ignorecase) {
2389 128 100       323 if (ref $range) {
2390 11412 100       31751 if (scalar(@{$range}) == 1) {
  214 50       233  
2391 214         502 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         5  
2392             }
2393 5         67 elsif (scalar(@{$range}) == 2) {
2394 209         296 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2395             }
2396             else {
2397 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         316  
  209         271  
2398             }
2399             }
2400             }
2401             }
2402              
2403             # return character list
2404 209 100       1079 if (scalar(@multipleoctet) >= 1) {
2405 239 100       623 if (scalar(@singleoctet) >= 1) {
2406              
2407             # any character other than multiple-octet and single octet character class
2408 114         250 return '(?!' . join('|', @multipleoctet) . ')(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2409             }
2410             else {
2411              
2412             # any character other than multiple-octet character class
2413 70         584 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2414             }
2415             }
2416             else {
2417 44 50       560 if (scalar(@singleoctet) >= 1) {
2418              
2419             # any character other than single octet character class
2420 125         333 return '(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2421             }
2422             else {
2423              
2424             # any character
2425 125         804 return "(?:$your_char)";
2426             }
2427             }
2428             }
2429              
2430             #
2431             # open file in read mode
2432             #
2433             sub _open_r {
2434 0     764   0 my(undef,$file) = @_;
2435 387     387   4968 use Fcntl qw(O_RDONLY);
  387         5201  
  387         89538  
2436 764         2178 return CORE::sysopen($_[0], $file, &O_RDONLY);
2437             }
2438              
2439             #
2440             # open file in append mode
2441             #
2442             sub _open_a {
2443 764     382   32423 my(undef,$file) = @_;
2444 387     387   6075 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  387         3989  
  387         6579103  
2445 382         2179 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2446             }
2447              
2448             #
2449             # safe system
2450             #
2451             sub _systemx {
2452              
2453             # P.707 29.2.33. exec
2454             # in Chapter 29: Functions
2455             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2456             #
2457             # Be aware that in older releases of Perl, exec (and system) did not flush
2458             # your output buffer, so you needed to enable command buffering by setting $|
2459             # on one or more filehandles to avoid lost output in the case of exec, or
2460             # misordererd output in the case of system. This situation was largely remedied
2461             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2462              
2463             # P.855 exec
2464             # in Chapter 27: Functions
2465             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2466             #
2467             # In very old release of Perl (before v5.6), exec (and system) did not flush
2468             # your output buffer, so you needed to enable command buffering by setting $|
2469             # on one or more filehandles to avoid lost output with exec or misordered
2470             # output with system.
2471              
2472 382     382   54619 $| = 1;
2473              
2474             # P.565 23.1.2. Cleaning Up Your Environment
2475             # in Chapter 23: Security
2476             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2477              
2478             # P.656 Cleaning Up Your Environment
2479             # in Chapter 20: Security
2480             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2481              
2482             # local $ENV{'PATH'} = '.';
2483 382         1596 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2484              
2485             # P.707 29.2.33. exec
2486             # in Chapter 29: Functions
2487             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2488             #
2489             # As we mentioned earlier, exec treats a discrete list of arguments as an
2490             # indication that it should bypass shell processing. However, there is one
2491             # place where you might still get tripped up. The exec call (and system, too)
2492             # will not distinguish between a single scalar argument and an array containing
2493             # only one element.
2494             #
2495             # @args = ("echo surprise"); # just one element in list
2496             # exec @args # still subject to shell escapes
2497             # or die "exec: $!"; # because @args == 1
2498             #
2499             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2500             # first argument as the pathname, which forces the rest of the arguments to be
2501             # interpreted as a list, even if there is only one of them:
2502             #
2503             # exec { $args[0] } @args # safe even with one-argument list
2504             # or die "can't exec @args: $!";
2505              
2506             # P.855 exec
2507             # in Chapter 27: Functions
2508             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2509             #
2510             # As we mentioned earlier, exec treats a discrete list of arguments as a
2511             # directive to bypass shell processing. However, there is one place where
2512             # you might still get tripped up. The exec call (and system, too) cannot
2513             # distinguish between a single scalar argument and an array containing
2514             # only one element.
2515             #
2516             # @args = ("echo surprise"); # just one element in list
2517             # exec @args # still subject to shell escapes
2518             # || die "exec: $!"; # because @args == 1
2519             #
2520             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2521             # argument as the pathname, which forces the rest of the arguments to be
2522             # interpreted as a list, even if there is only one of them:
2523             #
2524             # exec { $args[0] } @args # safe even with one-argument list
2525             # || die "can't exec @args: $!";
2526              
2527 382         3708 return CORE::system { $_[0] } @_; # safe even with one-argument list
  382         910  
2528             }
2529              
2530             #
2531             # KPS9566 order to character (with parameter)
2532             #
2533             sub Ekps9566::chr(;$) {
2534              
2535 382 0   0 0 55332571 my $c = @_ ? $_[0] : $_;
2536              
2537 0 0       0 if ($c == 0x00) {
2538 0         0 return "\x00";
2539             }
2540             else {
2541 0         0 my @chr = ();
2542 0         0 while ($c > 0) {
2543 0         0 unshift @chr, ($c % 0x100);
2544 0         0 $c = int($c / 0x100);
2545             }
2546 0         0 return pack 'C*', @chr;
2547             }
2548             }
2549              
2550             #
2551             # KPS9566 order to character (without parameter)
2552             #
2553             sub Ekps9566::chr_() {
2554              
2555 0     0 0 0 my $c = $_;
2556              
2557 0 0       0 if ($c == 0x00) {
2558 0         0 return "\x00";
2559             }
2560             else {
2561 0         0 my @chr = ();
2562 0         0 while ($c > 0) {
2563 0         0 unshift @chr, ($c % 0x100);
2564 0         0 $c = int($c / 0x100);
2565             }
2566 0         0 return pack 'C*', @chr;
2567             }
2568             }
2569              
2570             #
2571             # KPS9566 stacked file test expr
2572             #
2573             sub Ekps9566::filetest {
2574              
2575 0     0 0 0 my $file = pop @_;
2576 0         0 my $filetest = substr(pop @_, 1);
2577              
2578 0 0       0 unless (CORE::eval qq{Ekps9566::$filetest(\$file)}) {
2579 0         0 return '';
2580             }
2581 0         0 for my $filetest (CORE::reverse @_) {
2582 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
2583 0         0 return '';
2584             }
2585             }
2586 0         0 return 1;
2587             }
2588              
2589             #
2590             # KPS9566 file test -r expr
2591             #
2592             sub Ekps9566::r(;*@) {
2593              
2594 0 0   0 0 0 local $_ = shift if @_;
2595 0 0 0     0 croak 'Too many arguments for -r (Ekps9566::r)' if @_ and not wantarray;
2596              
2597 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2598 0 0       0 return wantarray ? (-r _,@_) : -r _;
2599             }
2600              
2601             # P.908 32.39. Symbol
2602             # in Chapter 32: Standard Modules
2603             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2604              
2605             # P.326 Prototypes
2606             # in Chapter 7: Subroutines
2607             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2608              
2609             # (and so on)
2610              
2611             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2612 0 0       0 return wantarray ? (-r $fh,@_) : -r $fh;
2613             }
2614             elsif (-e $_) {
2615 0 0       0 return wantarray ? (-r _,@_) : -r _;
2616             }
2617             elsif (_MSWin32_5Cended_path($_)) {
2618 0 0       0 if (-d "$_/.") {
2619 0 0       0 return wantarray ? (-r _,@_) : -r _;
2620             }
2621             else {
2622              
2623             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Ekps9566::*()
2624             # on Windows opens the file for the path which has 5c at end.
2625             # (and so on)
2626              
2627 0         0 my $fh = gensym();
2628 0 0       0 if (_open_r($fh, $_)) {
2629 0         0 my $r = -r $fh;
2630 0 0       0 close($fh) or die "Can't close file: $_: $!";
2631 0 0       0 return wantarray ? ($r,@_) : $r;
2632             }
2633             }
2634             }
2635 0 0       0 return wantarray ? (undef,@_) : undef;
2636             }
2637              
2638             #
2639             # KPS9566 file test -w expr
2640             #
2641             sub Ekps9566::w(;*@) {
2642              
2643 0 0   0 0 0 local $_ = shift if @_;
2644 0 0 0     0 croak 'Too many arguments for -w (Ekps9566::w)' if @_ and not wantarray;
2645              
2646 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2647 0 0       0 return wantarray ? (-w _,@_) : -w _;
2648             }
2649             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2650 0 0       0 return wantarray ? (-w $fh,@_) : -w $fh;
2651             }
2652             elsif (-e $_) {
2653 0 0       0 return wantarray ? (-w _,@_) : -w _;
2654             }
2655             elsif (_MSWin32_5Cended_path($_)) {
2656 0 0       0 if (-d "$_/.") {
2657 0 0       0 return wantarray ? (-w _,@_) : -w _;
2658             }
2659             else {
2660 0         0 my $fh = gensym();
2661 0 0       0 if (_open_a($fh, $_)) {
2662 0         0 my $w = -w $fh;
2663 0 0       0 close($fh) or die "Can't close file: $_: $!";
2664 0 0       0 return wantarray ? ($w,@_) : $w;
2665             }
2666             }
2667             }
2668 0 0       0 return wantarray ? (undef,@_) : undef;
2669             }
2670              
2671             #
2672             # KPS9566 file test -x expr
2673             #
2674             sub Ekps9566::x(;*@) {
2675              
2676 0 0   0 0 0 local $_ = shift if @_;
2677 0 0 0     0 croak 'Too many arguments for -x (Ekps9566::x)' if @_ and not wantarray;
2678              
2679 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2680 0 0       0 return wantarray ? (-x _,@_) : -x _;
2681             }
2682             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2683 0 0       0 return wantarray ? (-x $fh,@_) : -x $fh;
2684             }
2685             elsif (-e $_) {
2686 0 0       0 return wantarray ? (-x _,@_) : -x _;
2687             }
2688             elsif (_MSWin32_5Cended_path($_)) {
2689 0 0       0 if (-d "$_/.") {
2690 0 0       0 return wantarray ? (-x _,@_) : -x _;
2691             }
2692             else {
2693 0         0 my $fh = gensym();
2694 0 0       0 if (_open_r($fh, $_)) {
2695 0         0 my $dummy_for_underline_cache = -x $fh;
2696 0 0       0 close($fh) or die "Can't close file: $_: $!";
2697             }
2698              
2699             # filename is not .COM .EXE .BAT .CMD
2700 0 0       0 return wantarray ? ('',@_) : '';
2701             }
2702             }
2703 0 0       0 return wantarray ? (undef,@_) : undef;
2704             }
2705              
2706             #
2707             # KPS9566 file test -o expr
2708             #
2709             sub Ekps9566::o(;*@) {
2710              
2711 0 0   0 0 0 local $_ = shift if @_;
2712 0 0 0     0 croak 'Too many arguments for -o (Ekps9566::o)' if @_ and not wantarray;
2713              
2714 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2715 0 0       0 return wantarray ? (-o _,@_) : -o _;
2716             }
2717             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2718 0 0       0 return wantarray ? (-o $fh,@_) : -o $fh;
2719             }
2720             elsif (-e $_) {
2721 0 0       0 return wantarray ? (-o _,@_) : -o _;
2722             }
2723             elsif (_MSWin32_5Cended_path($_)) {
2724 0 0       0 if (-d "$_/.") {
2725 0 0       0 return wantarray ? (-o _,@_) : -o _;
2726             }
2727             else {
2728 0         0 my $fh = gensym();
2729 0 0       0 if (_open_r($fh, $_)) {
2730 0         0 my $o = -o $fh;
2731 0 0       0 close($fh) or die "Can't close file: $_: $!";
2732 0 0       0 return wantarray ? ($o,@_) : $o;
2733             }
2734             }
2735             }
2736 0 0       0 return wantarray ? (undef,@_) : undef;
2737             }
2738              
2739             #
2740             # KPS9566 file test -R expr
2741             #
2742             sub Ekps9566::R(;*@) {
2743              
2744 0 0   0 0 0 local $_ = shift if @_;
2745 0 0 0     0 croak 'Too many arguments for -R (Ekps9566::R)' if @_ and not wantarray;
2746              
2747 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2748 0 0       0 return wantarray ? (-R _,@_) : -R _;
2749             }
2750             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2751 0 0       0 return wantarray ? (-R $fh,@_) : -R $fh;
2752             }
2753             elsif (-e $_) {
2754 0 0       0 return wantarray ? (-R _,@_) : -R _;
2755             }
2756             elsif (_MSWin32_5Cended_path($_)) {
2757 0 0       0 if (-d "$_/.") {
2758 0 0       0 return wantarray ? (-R _,@_) : -R _;
2759             }
2760             else {
2761 0         0 my $fh = gensym();
2762 0 0       0 if (_open_r($fh, $_)) {
2763 0         0 my $R = -R $fh;
2764 0 0       0 close($fh) or die "Can't close file: $_: $!";
2765 0 0       0 return wantarray ? ($R,@_) : $R;
2766             }
2767             }
2768             }
2769 0 0       0 return wantarray ? (undef,@_) : undef;
2770             }
2771              
2772             #
2773             # KPS9566 file test -W expr
2774             #
2775             sub Ekps9566::W(;*@) {
2776              
2777 0 0   0 0 0 local $_ = shift if @_;
2778 0 0 0     0 croak 'Too many arguments for -W (Ekps9566::W)' if @_ and not wantarray;
2779              
2780 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2781 0 0       0 return wantarray ? (-W _,@_) : -W _;
2782             }
2783             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2784 0 0       0 return wantarray ? (-W $fh,@_) : -W $fh;
2785             }
2786             elsif (-e $_) {
2787 0 0       0 return wantarray ? (-W _,@_) : -W _;
2788             }
2789             elsif (_MSWin32_5Cended_path($_)) {
2790 0 0       0 if (-d "$_/.") {
2791 0 0       0 return wantarray ? (-W _,@_) : -W _;
2792             }
2793             else {
2794 0         0 my $fh = gensym();
2795 0 0       0 if (_open_a($fh, $_)) {
2796 0         0 my $W = -W $fh;
2797 0 0       0 close($fh) or die "Can't close file: $_: $!";
2798 0 0       0 return wantarray ? ($W,@_) : $W;
2799             }
2800             }
2801             }
2802 0 0       0 return wantarray ? (undef,@_) : undef;
2803             }
2804              
2805             #
2806             # KPS9566 file test -X expr
2807             #
2808             sub Ekps9566::X(;*@) {
2809              
2810 0 0   0 1 0 local $_ = shift if @_;
2811 0 0 0     0 croak 'Too many arguments for -X (Ekps9566::X)' if @_ and not wantarray;
2812              
2813 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2814 0 0       0 return wantarray ? (-X _,@_) : -X _;
2815             }
2816             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2817 0 0       0 return wantarray ? (-X $fh,@_) : -X $fh;
2818             }
2819             elsif (-e $_) {
2820 0 0       0 return wantarray ? (-X _,@_) : -X _;
2821             }
2822             elsif (_MSWin32_5Cended_path($_)) {
2823 0 0       0 if (-d "$_/.") {
2824 0 0       0 return wantarray ? (-X _,@_) : -X _;
2825             }
2826             else {
2827 0         0 my $fh = gensym();
2828 0 0       0 if (_open_r($fh, $_)) {
2829 0         0 my $dummy_for_underline_cache = -X $fh;
2830 0 0       0 close($fh) or die "Can't close file: $_: $!";
2831             }
2832              
2833             # filename is not .COM .EXE .BAT .CMD
2834 0 0       0 return wantarray ? ('',@_) : '';
2835             }
2836             }
2837 0 0       0 return wantarray ? (undef,@_) : undef;
2838             }
2839              
2840             #
2841             # KPS9566 file test -O expr
2842             #
2843             sub Ekps9566::O(;*@) {
2844              
2845 0 0   0 0 0 local $_ = shift if @_;
2846 0 0 0     0 croak 'Too many arguments for -O (Ekps9566::O)' if @_ and not wantarray;
2847              
2848 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2849 0 0       0 return wantarray ? (-O _,@_) : -O _;
2850             }
2851             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2852 0 0       0 return wantarray ? (-O $fh,@_) : -O $fh;
2853             }
2854             elsif (-e $_) {
2855 0 0       0 return wantarray ? (-O _,@_) : -O _;
2856             }
2857             elsif (_MSWin32_5Cended_path($_)) {
2858 0 0       0 if (-d "$_/.") {
2859 0 0       0 return wantarray ? (-O _,@_) : -O _;
2860             }
2861             else {
2862 0         0 my $fh = gensym();
2863 0 0       0 if (_open_r($fh, $_)) {
2864 0         0 my $O = -O $fh;
2865 0 0       0 close($fh) or die "Can't close file: $_: $!";
2866 0 0       0 return wantarray ? ($O,@_) : $O;
2867             }
2868             }
2869             }
2870 0 0       0 return wantarray ? (undef,@_) : undef;
2871             }
2872              
2873             #
2874             # KPS9566 file test -e expr
2875             #
2876             sub Ekps9566::e(;*@) {
2877              
2878 0 50   764 0 0 local $_ = shift if @_;
2879 764 50 33     3169 croak 'Too many arguments for -e (Ekps9566::e)' if @_ and not wantarray;
2880              
2881 764         3451 local $^W = 0;
2882              
2883 764         2387 my $fh = qualify_to_ref $_;
2884 764 50       2162 if ($_ eq '_') {
    50          
    50          
    50          
    50          
2885 764 0       3647 return wantarray ? (-e _,@_) : -e _;
2886             }
2887              
2888             # return false if directory handle
2889             elsif (defined Ekps9566::telldir($fh)) {
2890 0 0       0 return wantarray ? ('',@_) : '';
2891             }
2892              
2893             # return true if file handle
2894             elsif (defined fileno $fh) {
2895 0 0       0 return wantarray ? (1,@_) : 1;
2896             }
2897              
2898             elsif (-e $_) {
2899 0 0       0 return wantarray ? (1,@_) : 1;
2900             }
2901             elsif (_MSWin32_5Cended_path($_)) {
2902 0 0       0 if (-d "$_/.") {
2903 0 0       0 return wantarray ? (1,@_) : 1;
2904             }
2905             else {
2906 0         0 my $fh = gensym();
2907 0 0       0 if (_open_r($fh, $_)) {
2908 0         0 my $e = -e $fh;
2909 0 0       0 close($fh) or die "Can't close file: $_: $!";
2910 0 0       0 return wantarray ? ($e,@_) : $e;
2911             }
2912             }
2913             }
2914 0 50       0 return wantarray ? (undef,@_) : undef;
2915             }
2916              
2917             #
2918             # KPS9566 file test -z expr
2919             #
2920             sub Ekps9566::z(;*@) {
2921              
2922 764 0   0 0 5852 local $_ = shift if @_;
2923 0 0 0     0 croak 'Too many arguments for -z (Ekps9566::z)' if @_ and not wantarray;
2924              
2925 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2926 0 0       0 return wantarray ? (-z _,@_) : -z _;
2927             }
2928             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2929 0 0       0 return wantarray ? (-z $fh,@_) : -z $fh;
2930             }
2931             elsif (-e $_) {
2932 0 0       0 return wantarray ? (-z _,@_) : -z _;
2933             }
2934             elsif (_MSWin32_5Cended_path($_)) {
2935 0 0       0 if (-d "$_/.") {
2936 0 0       0 return wantarray ? (-z _,@_) : -z _;
2937             }
2938             else {
2939 0         0 my $fh = gensym();
2940 0 0       0 if (_open_r($fh, $_)) {
2941 0         0 my $z = -z $fh;
2942 0 0       0 close($fh) or die "Can't close file: $_: $!";
2943 0 0       0 return wantarray ? ($z,@_) : $z;
2944             }
2945             }
2946             }
2947 0 0       0 return wantarray ? (undef,@_) : undef;
2948             }
2949              
2950             #
2951             # KPS9566 file test -s expr
2952             #
2953             sub Ekps9566::s(;*@) {
2954              
2955 0 0   0 0 0 local $_ = shift if @_;
2956 0 0 0     0 croak 'Too many arguments for -s (Ekps9566::s)' if @_ and not wantarray;
2957              
2958 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2959 0 0       0 return wantarray ? (-s _,@_) : -s _;
2960             }
2961             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2962 0 0       0 return wantarray ? (-s $fh,@_) : -s $fh;
2963             }
2964             elsif (-e $_) {
2965 0 0       0 return wantarray ? (-s _,@_) : -s _;
2966             }
2967             elsif (_MSWin32_5Cended_path($_)) {
2968 0 0       0 if (-d "$_/.") {
2969 0 0       0 return wantarray ? (-s _,@_) : -s _;
2970             }
2971             else {
2972 0         0 my $fh = gensym();
2973 0 0       0 if (_open_r($fh, $_)) {
2974 0         0 my $s = -s $fh;
2975 0 0       0 close($fh) or die "Can't close file: $_: $!";
2976 0 0       0 return wantarray ? ($s,@_) : $s;
2977             }
2978             }
2979             }
2980 0 0       0 return wantarray ? (undef,@_) : undef;
2981             }
2982              
2983             #
2984             # KPS9566 file test -f expr
2985             #
2986             sub Ekps9566::f(;*@) {
2987              
2988 0 0   0 0 0 local $_ = shift if @_;
2989 0 0 0     0 croak 'Too many arguments for -f (Ekps9566::f)' if @_ and not wantarray;
2990              
2991 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2992 0 0       0 return wantarray ? (-f _,@_) : -f _;
2993             }
2994             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2995 0 0       0 return wantarray ? (-f $fh,@_) : -f $fh;
2996             }
2997             elsif (-e $_) {
2998 0 0       0 return wantarray ? (-f _,@_) : -f _;
2999             }
3000             elsif (_MSWin32_5Cended_path($_)) {
3001 0 0       0 if (-d "$_/.") {
3002 0 0       0 return wantarray ? ('',@_) : '';
3003             }
3004             else {
3005 0         0 my $fh = gensym();
3006 0 0       0 if (_open_r($fh, $_)) {
3007 0         0 my $f = -f $fh;
3008 0 0       0 close($fh) or die "Can't close file: $_: $!";
3009 0 0       0 return wantarray ? ($f,@_) : $f;
3010             }
3011             }
3012             }
3013 0 0       0 return wantarray ? (undef,@_) : undef;
3014             }
3015              
3016             #
3017             # KPS9566 file test -d expr
3018             #
3019             sub Ekps9566::d(;*@) {
3020              
3021 0 0   0 0 0 local $_ = shift if @_;
3022 0 0 0     0 croak 'Too many arguments for -d (Ekps9566::d)' if @_ and not wantarray;
3023              
3024 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3025 0 0       0 return wantarray ? (-d _,@_) : -d _;
3026             }
3027              
3028             # return false if file handle or directory handle
3029             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3030 0 0       0 return wantarray ? ('',@_) : '';
3031             }
3032             elsif (-e $_) {
3033 0 0       0 return wantarray ? (-d _,@_) : -d _;
3034             }
3035             elsif (_MSWin32_5Cended_path($_)) {
3036 0 0       0 return wantarray ? (-d "$_/.",@_) : -d "$_/.";
3037             }
3038 0 0       0 return wantarray ? (undef,@_) : undef;
3039             }
3040              
3041             #
3042             # KPS9566 file test -l expr
3043             #
3044             sub Ekps9566::l(;*@) {
3045              
3046 0 0   0 0 0 local $_ = shift if @_;
3047 0 0 0     0 croak 'Too many arguments for -l (Ekps9566::l)' if @_ and not wantarray;
3048              
3049 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3050 0 0       0 return wantarray ? (-l _,@_) : -l _;
3051             }
3052             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3053 0 0       0 return wantarray ? (-l $fh,@_) : -l $fh;
3054             }
3055             elsif (-e $_) {
3056 0 0       0 return wantarray ? (-l _,@_) : -l _;
3057             }
3058             elsif (_MSWin32_5Cended_path($_)) {
3059 0 0       0 if (-d "$_/.") {
3060 0 0       0 return wantarray ? (-l _,@_) : -l _;
3061             }
3062             else {
3063 0         0 my $fh = gensym();
3064 0 0       0 if (_open_r($fh, $_)) {
3065 0         0 my $l = -l $fh;
3066 0 0       0 close($fh) or die "Can't close file: $_: $!";
3067 0 0       0 return wantarray ? ($l,@_) : $l;
3068             }
3069             }
3070             }
3071 0 0       0 return wantarray ? (undef,@_) : undef;
3072             }
3073              
3074             #
3075             # KPS9566 file test -p expr
3076             #
3077             sub Ekps9566::p(;*@) {
3078              
3079 0 0   0 0 0 local $_ = shift if @_;
3080 0 0 0     0 croak 'Too many arguments for -p (Ekps9566::p)' if @_ and not wantarray;
3081              
3082 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3083 0 0       0 return wantarray ? (-p _,@_) : -p _;
3084             }
3085             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3086 0 0       0 return wantarray ? (-p $fh,@_) : -p $fh;
3087             }
3088             elsif (-e $_) {
3089 0 0       0 return wantarray ? (-p _,@_) : -p _;
3090             }
3091             elsif (_MSWin32_5Cended_path($_)) {
3092 0 0       0 if (-d "$_/.") {
3093 0 0       0 return wantarray ? (-p _,@_) : -p _;
3094             }
3095             else {
3096 0         0 my $fh = gensym();
3097 0 0       0 if (_open_r($fh, $_)) {
3098 0         0 my $p = -p $fh;
3099 0 0       0 close($fh) or die "Can't close file: $_: $!";
3100 0 0       0 return wantarray ? ($p,@_) : $p;
3101             }
3102             }
3103             }
3104 0 0       0 return wantarray ? (undef,@_) : undef;
3105             }
3106              
3107             #
3108             # KPS9566 file test -S expr
3109             #
3110             sub Ekps9566::S(;*@) {
3111              
3112 0 0   0 0 0 local $_ = shift if @_;
3113 0 0 0     0 croak 'Too many arguments for -S (Ekps9566::S)' if @_ and not wantarray;
3114              
3115 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3116 0 0       0 return wantarray ? (-S _,@_) : -S _;
3117             }
3118             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3119 0 0       0 return wantarray ? (-S $fh,@_) : -S $fh;
3120             }
3121             elsif (-e $_) {
3122 0 0       0 return wantarray ? (-S _,@_) : -S _;
3123             }
3124             elsif (_MSWin32_5Cended_path($_)) {
3125 0 0       0 if (-d "$_/.") {
3126 0 0       0 return wantarray ? (-S _,@_) : -S _;
3127             }
3128             else {
3129 0         0 my $fh = gensym();
3130 0 0       0 if (_open_r($fh, $_)) {
3131 0         0 my $S = -S $fh;
3132 0 0       0 close($fh) or die "Can't close file: $_: $!";
3133 0 0       0 return wantarray ? ($S,@_) : $S;
3134             }
3135             }
3136             }
3137 0 0       0 return wantarray ? (undef,@_) : undef;
3138             }
3139              
3140             #
3141             # KPS9566 file test -b expr
3142             #
3143             sub Ekps9566::b(;*@) {
3144              
3145 0 0   0 0 0 local $_ = shift if @_;
3146 0 0 0     0 croak 'Too many arguments for -b (Ekps9566::b)' if @_ and not wantarray;
3147              
3148 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3149 0 0       0 return wantarray ? (-b _,@_) : -b _;
3150             }
3151             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3152 0 0       0 return wantarray ? (-b $fh,@_) : -b $fh;
3153             }
3154             elsif (-e $_) {
3155 0 0       0 return wantarray ? (-b _,@_) : -b _;
3156             }
3157             elsif (_MSWin32_5Cended_path($_)) {
3158 0 0       0 if (-d "$_/.") {
3159 0 0       0 return wantarray ? (-b _,@_) : -b _;
3160             }
3161             else {
3162 0         0 my $fh = gensym();
3163 0 0       0 if (_open_r($fh, $_)) {
3164 0         0 my $b = -b $fh;
3165 0 0       0 close($fh) or die "Can't close file: $_: $!";
3166 0 0       0 return wantarray ? ($b,@_) : $b;
3167             }
3168             }
3169             }
3170 0 0       0 return wantarray ? (undef,@_) : undef;
3171             }
3172              
3173             #
3174             # KPS9566 file test -c expr
3175             #
3176             sub Ekps9566::c(;*@) {
3177              
3178 0 0   0 0 0 local $_ = shift if @_;
3179 0 0 0     0 croak 'Too many arguments for -c (Ekps9566::c)' if @_ and not wantarray;
3180              
3181 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3182 0 0       0 return wantarray ? (-c _,@_) : -c _;
3183             }
3184             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3185 0 0       0 return wantarray ? (-c $fh,@_) : -c $fh;
3186             }
3187             elsif (-e $_) {
3188 0 0       0 return wantarray ? (-c _,@_) : -c _;
3189             }
3190             elsif (_MSWin32_5Cended_path($_)) {
3191 0 0       0 if (-d "$_/.") {
3192 0 0       0 return wantarray ? (-c _,@_) : -c _;
3193             }
3194             else {
3195 0         0 my $fh = gensym();
3196 0 0       0 if (_open_r($fh, $_)) {
3197 0         0 my $c = -c $fh;
3198 0 0       0 close($fh) or die "Can't close file: $_: $!";
3199 0 0       0 return wantarray ? ($c,@_) : $c;
3200             }
3201             }
3202             }
3203 0 0       0 return wantarray ? (undef,@_) : undef;
3204             }
3205              
3206             #
3207             # KPS9566 file test -u expr
3208             #
3209             sub Ekps9566::u(;*@) {
3210              
3211 0 0   0 0 0 local $_ = shift if @_;
3212 0 0 0     0 croak 'Too many arguments for -u (Ekps9566::u)' if @_ and not wantarray;
3213              
3214 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3215 0 0       0 return wantarray ? (-u _,@_) : -u _;
3216             }
3217             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3218 0 0       0 return wantarray ? (-u $fh,@_) : -u $fh;
3219             }
3220             elsif (-e $_) {
3221 0 0       0 return wantarray ? (-u _,@_) : -u _;
3222             }
3223             elsif (_MSWin32_5Cended_path($_)) {
3224 0 0       0 if (-d "$_/.") {
3225 0 0       0 return wantarray ? (-u _,@_) : -u _;
3226             }
3227             else {
3228 0         0 my $fh = gensym();
3229 0 0       0 if (_open_r($fh, $_)) {
3230 0         0 my $u = -u $fh;
3231 0 0       0 close($fh) or die "Can't close file: $_: $!";
3232 0 0       0 return wantarray ? ($u,@_) : $u;
3233             }
3234             }
3235             }
3236 0 0       0 return wantarray ? (undef,@_) : undef;
3237             }
3238              
3239             #
3240             # KPS9566 file test -g expr
3241             #
3242             sub Ekps9566::g(;*@) {
3243              
3244 0 0   0 0 0 local $_ = shift if @_;
3245 0 0 0     0 croak 'Too many arguments for -g (Ekps9566::g)' if @_ and not wantarray;
3246              
3247 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3248 0 0       0 return wantarray ? (-g _,@_) : -g _;
3249             }
3250             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3251 0 0       0 return wantarray ? (-g $fh,@_) : -g $fh;
3252             }
3253             elsif (-e $_) {
3254 0 0       0 return wantarray ? (-g _,@_) : -g _;
3255             }
3256             elsif (_MSWin32_5Cended_path($_)) {
3257 0 0       0 if (-d "$_/.") {
3258 0 0       0 return wantarray ? (-g _,@_) : -g _;
3259             }
3260             else {
3261 0         0 my $fh = gensym();
3262 0 0       0 if (_open_r($fh, $_)) {
3263 0         0 my $g = -g $fh;
3264 0 0       0 close($fh) or die "Can't close file: $_: $!";
3265 0 0       0 return wantarray ? ($g,@_) : $g;
3266             }
3267             }
3268             }
3269 0 0       0 return wantarray ? (undef,@_) : undef;
3270             }
3271              
3272             #
3273             # KPS9566 file test -k expr
3274             #
3275             sub Ekps9566::k(;*@) {
3276              
3277 0 0   0 0 0 local $_ = shift if @_;
3278 0 0 0     0 croak 'Too many arguments for -k (Ekps9566::k)' if @_ and not wantarray;
3279              
3280 0 0       0 if ($_ eq '_') {
    0          
    0          
3281 0 0       0 return wantarray ? ('',@_) : '';
3282             }
3283             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3284 0 0       0 return wantarray ? ('',@_) : '';
3285             }
3286             elsif ($] =~ /^5\.008/oxms) {
3287 0 0       0 return wantarray ? ('',@_) : '';
3288             }
3289 0 0       0 return wantarray ? ($_,@_) : $_;
3290             }
3291              
3292             #
3293             # KPS9566 file test -T expr
3294             #
3295             sub Ekps9566::T(;*@) {
3296              
3297 0 0   0 0 0 local $_ = shift if @_;
3298              
3299             # Use of croak without parentheses makes die on Strawberry Perl 5.008 and 5.010, like:
3300             # croak 'Too many arguments for -T (Ekps9566::T)';
3301             # Must be used by parentheses like:
3302             # croak('Too many arguments for -T (Ekps9566::T)');
3303              
3304 0 0 0     0 if (@_ and not wantarray) {
3305 0         0 croak('Too many arguments for -T (Ekps9566::T)');
3306             }
3307              
3308 0         0 my $T = 1;
3309              
3310 0         0 my $fh = qualify_to_ref $_;
3311 0 0       0 if (defined fileno $fh) {
3312              
3313 0 0       0 if (defined Ekps9566::telldir($fh)) {
3314 0 0       0 return wantarray ? (undef,@_) : undef;
3315             }
3316              
3317             # P.813 29.2.176. tell
3318             # in Chapter 29: Functions
3319             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3320              
3321             # P.970 tell
3322             # in Chapter 27: Functions
3323             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3324              
3325             # (and so on)
3326              
3327 0         0 my $systell = sysseek $fh, 0, 1;
3328              
3329 0 0       0 if (sysread $fh, my $block, 512) {
3330              
3331             # P.163 Binary file check in Little Perl Parlor 16
3332             # of Book No. T1008901080816 ZASSHI 08901-8 UNIX MAGAZINE 1993 Aug VOL8#8
3333             # (and so on)
3334              
3335 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3336 0         0 $T = '';
3337             }
3338             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3339 0         0 $T = '';
3340             }
3341             }
3342              
3343             # 0 byte or eof
3344             else {
3345 0         0 $T = 1;
3346             }
3347              
3348 0         0 my $dummy_for_underline_cache = -T $fh;
3349 0         0 sysseek $fh, $systell, 0;
3350             }
3351             else {
3352 0 0 0     0 if (-d $_ or -d "$_/.") {
3353 0 0       0 return wantarray ? (undef,@_) : undef;
3354             }
3355              
3356 0         0 $fh = gensym();
3357 0 0       0 if (_open_r($fh, $_)) {
3358             }
3359             else {
3360 0 0       0 return wantarray ? (undef,@_) : undef;
3361             }
3362 0 0       0 if (sysread $fh, my $block, 512) {
3363 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3364 0         0 $T = '';
3365             }
3366             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3367 0         0 $T = '';
3368             }
3369             }
3370              
3371             # 0 byte or eof
3372             else {
3373 0         0 $T = 1;
3374             }
3375 0         0 my $dummy_for_underline_cache = -T $fh;
3376 0 0       0 close($fh) or die "Can't close file: $_: $!";
3377             }
3378              
3379 0 0       0 return wantarray ? ($T,@_) : $T;
3380             }
3381              
3382             #
3383             # KPS9566 file test -B expr
3384             #
3385             sub Ekps9566::B(;*@) {
3386              
3387 0 0   0 0 0 local $_ = shift if @_;
3388 0 0 0     0 croak 'Too many arguments for -B (Ekps9566::B)' if @_ and not wantarray;
3389 0         0 my $B = '';
3390              
3391 0         0 my $fh = qualify_to_ref $_;
3392 0 0       0 if (defined fileno $fh) {
3393              
3394 0 0       0 if (defined Ekps9566::telldir($fh)) {
3395 0 0       0 return wantarray ? (undef,@_) : undef;
3396             }
3397              
3398 0         0 my $systell = sysseek $fh, 0, 1;
3399              
3400 0 0       0 if (sysread $fh, my $block, 512) {
3401 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3402 0         0 $B = 1;
3403             }
3404             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3405 0         0 $B = 1;
3406             }
3407             }
3408              
3409             # 0 byte or eof
3410             else {
3411 0         0 $B = 1;
3412             }
3413              
3414 0         0 my $dummy_for_underline_cache = -B $fh;
3415 0         0 sysseek $fh, $systell, 0;
3416             }
3417             else {
3418 0 0 0     0 if (-d $_ or -d "$_/.") {
3419 0 0       0 return wantarray ? (undef,@_) : undef;
3420             }
3421              
3422 0         0 $fh = gensym();
3423 0 0       0 if (_open_r($fh, $_)) {
3424             }
3425             else {
3426 0 0       0 return wantarray ? (undef,@_) : undef;
3427             }
3428 0 0       0 if (sysread $fh, my $block, 512) {
3429 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3430 0         0 $B = 1;
3431             }
3432             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3433 0         0 $B = 1;
3434             }
3435             }
3436              
3437             # 0 byte or eof
3438             else {
3439 0         0 $B = 1;
3440             }
3441 0         0 my $dummy_for_underline_cache = -B $fh;
3442 0 0       0 close($fh) or die "Can't close file: $_: $!";
3443             }
3444              
3445 0 0       0 return wantarray ? ($B,@_) : $B;
3446             }
3447              
3448             #
3449             # KPS9566 file test -M expr
3450             #
3451             sub Ekps9566::M(;*@) {
3452              
3453 0 0   0 0 0 local $_ = shift if @_;
3454 0 0 0     0 croak 'Too many arguments for -M (Ekps9566::M)' if @_ and not wantarray;
3455              
3456 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3457 0 0       0 return wantarray ? (-M _,@_) : -M _;
3458             }
3459             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3460 0 0       0 return wantarray ? (-M $fh,@_) : -M $fh;
3461             }
3462             elsif (-e $_) {
3463 0 0       0 return wantarray ? (-M _,@_) : -M _;
3464             }
3465             elsif (_MSWin32_5Cended_path($_)) {
3466 0 0       0 if (-d "$_/.") {
3467 0 0       0 return wantarray ? (-M _,@_) : -M _;
3468             }
3469             else {
3470 0         0 my $fh = gensym();
3471 0 0       0 if (_open_r($fh, $_)) {
3472 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3473 0 0       0 close($fh) or die "Can't close file: $_: $!";
3474 0         0 my $M = ($^T - $mtime) / (24*60*60);
3475 0 0       0 return wantarray ? ($M,@_) : $M;
3476             }
3477             }
3478             }
3479 0 0       0 return wantarray ? (undef,@_) : undef;
3480             }
3481              
3482             #
3483             # KPS9566 file test -A expr
3484             #
3485             sub Ekps9566::A(;*@) {
3486              
3487 0 0   0 0 0 local $_ = shift if @_;
3488 0 0 0     0 croak 'Too many arguments for -A (Ekps9566::A)' if @_ and not wantarray;
3489              
3490 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3491 0 0       0 return wantarray ? (-A _,@_) : -A _;
3492             }
3493             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3494 0 0       0 return wantarray ? (-A $fh,@_) : -A $fh;
3495             }
3496             elsif (-e $_) {
3497 0 0       0 return wantarray ? (-A _,@_) : -A _;
3498             }
3499             elsif (_MSWin32_5Cended_path($_)) {
3500 0 0       0 if (-d "$_/.") {
3501 0 0       0 return wantarray ? (-A _,@_) : -A _;
3502             }
3503             else {
3504 0         0 my $fh = gensym();
3505 0 0       0 if (_open_r($fh, $_)) {
3506 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3507 0 0       0 close($fh) or die "Can't close file: $_: $!";
3508 0         0 my $A = ($^T - $atime) / (24*60*60);
3509 0 0       0 return wantarray ? ($A,@_) : $A;
3510             }
3511             }
3512             }
3513 0 0       0 return wantarray ? (undef,@_) : undef;
3514             }
3515              
3516             #
3517             # KPS9566 file test -C expr
3518             #
3519             sub Ekps9566::C(;*@) {
3520              
3521 0 0   0 0 0 local $_ = shift if @_;
3522 0 0 0     0 croak 'Too many arguments for -C (Ekps9566::C)' if @_ and not wantarray;
3523              
3524 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3525 0 0       0 return wantarray ? (-C _,@_) : -C _;
3526             }
3527             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3528 0 0       0 return wantarray ? (-C $fh,@_) : -C $fh;
3529             }
3530             elsif (-e $_) {
3531 0 0       0 return wantarray ? (-C _,@_) : -C _;
3532             }
3533             elsif (_MSWin32_5Cended_path($_)) {
3534 0 0       0 if (-d "$_/.") {
3535 0 0       0 return wantarray ? (-C _,@_) : -C _;
3536             }
3537             else {
3538 0         0 my $fh = gensym();
3539 0 0       0 if (_open_r($fh, $_)) {
3540 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3541 0 0       0 close($fh) or die "Can't close file: $_: $!";
3542 0         0 my $C = ($^T - $ctime) / (24*60*60);
3543 0 0       0 return wantarray ? ($C,@_) : $C;
3544             }
3545             }
3546             }
3547 0 0       0 return wantarray ? (undef,@_) : undef;
3548             }
3549              
3550             #
3551             # KPS9566 stacked file test $_
3552             #
3553             sub Ekps9566::filetest_ {
3554              
3555 0     0 0 0 my $filetest = substr(pop @_, 1);
3556              
3557 0 0       0 unless (CORE::eval qq{Ekps9566::${filetest}_}) {
3558 0         0 return '';
3559             }
3560 0         0 for my $filetest (CORE::reverse @_) {
3561 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
3562 0         0 return '';
3563             }
3564             }
3565 0         0 return 1;
3566             }
3567              
3568             #
3569             # KPS9566 file test -r $_
3570             #
3571             sub Ekps9566::r_() {
3572              
3573 0 0   0 0 0 if (-e $_) {
    0          
3574 0 0       0 return -r _ ? 1 : '';
3575             }
3576             elsif (_MSWin32_5Cended_path($_)) {
3577 0 0       0 if (-d "$_/.") {
3578 0 0       0 return -r _ ? 1 : '';
3579             }
3580             else {
3581 0         0 my $fh = gensym();
3582 0 0       0 if (_open_r($fh, $_)) {
3583 0         0 my $r = -r $fh;
3584 0 0       0 close($fh) or die "Can't close file: $_: $!";
3585 0 0       0 return $r ? 1 : '';
3586             }
3587             }
3588             }
3589              
3590             # 10.10. Returning Failure
3591             # in Chapter 10. Subroutines
3592             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3593             # (and so on)
3594              
3595             # 2010-01-26 The difference of "return;" and "return undef;"
3596             # http://d.hatena.ne.jp/gfx/20100126/1264474754
3597             #
3598             # "Perl Best Practices" recommends to use "return;"*1 to return nothing, but
3599             # it might be wrong in some cases. If you use this idiom for those functions
3600             # which are expected to return a scalar value, e.g. searching functions, the
3601             # user of those functions will be surprised at what they return in list
3602             # context, an empty list - note that many functions and all the methods
3603             # evaluate their arguments in list context. You'd better to use "return undef;"
3604             # for such scalar functions.
3605             #
3606             # sub search_something {
3607             # my($arg) = @_;
3608             # # search_something...
3609             # if(defined $found){
3610             # return $found;
3611             # }
3612             # return; # XXX: you'd better to "return undef;"
3613             # }
3614             #
3615             # # ...
3616             #
3617             # # you'll get what you want, but ...
3618             # my $something = search_something($source);
3619             #
3620             # # you won't get what you want here.
3621             # # @_ for doit() is (-foo => $opt), not (undef, -foo => $opt).
3622             # $obj->doit(search_something($source), -option=> $optval);
3623             #
3624             # # you have to use the "scalar" operator in such a case.
3625             # $obj->doit(scalar search_something($source), ...);
3626             #
3627             # *1: it returns an empty list in list context, or returns undef in scalar
3628             # context
3629             #
3630             # (and so on)
3631              
3632 0         0 return undef;
3633             }
3634              
3635             #
3636             # KPS9566 file test -w $_
3637             #
3638             sub Ekps9566::w_() {
3639              
3640 0 0   0 0 0 if (-e $_) {
    0          
3641 0 0       0 return -w _ ? 1 : '';
3642             }
3643             elsif (_MSWin32_5Cended_path($_)) {
3644 0 0       0 if (-d "$_/.") {
3645 0 0       0 return -w _ ? 1 : '';
3646             }
3647             else {
3648 0         0 my $fh = gensym();
3649 0 0       0 if (_open_a($fh, $_)) {
3650 0         0 my $w = -w $fh;
3651 0 0       0 close($fh) or die "Can't close file: $_: $!";
3652 0 0       0 return $w ? 1 : '';
3653             }
3654             }
3655             }
3656 0         0 return undef;
3657             }
3658              
3659             #
3660             # KPS9566 file test -x $_
3661             #
3662             sub Ekps9566::x_() {
3663              
3664 0 0   0 0 0 if (-e $_) {
    0          
3665 0 0       0 return -x _ ? 1 : '';
3666             }
3667             elsif (_MSWin32_5Cended_path($_)) {
3668 0 0       0 if (-d "$_/.") {
3669 0 0       0 return -x _ ? 1 : '';
3670             }
3671             else {
3672 0         0 my $fh = gensym();
3673 0 0       0 if (_open_r($fh, $_)) {
3674 0         0 my $dummy_for_underline_cache = -x $fh;
3675 0 0       0 close($fh) or die "Can't close file: $_: $!";
3676             }
3677              
3678             # filename is not .COM .EXE .BAT .CMD
3679 0         0 return '';
3680             }
3681             }
3682 0         0 return undef;
3683             }
3684              
3685             #
3686             # KPS9566 file test -o $_
3687             #
3688             sub Ekps9566::o_() {
3689              
3690 0 0   0 0 0 if (-e $_) {
    0          
3691 0 0       0 return -o _ ? 1 : '';
3692             }
3693             elsif (_MSWin32_5Cended_path($_)) {
3694 0 0       0 if (-d "$_/.") {
3695 0 0       0 return -o _ ? 1 : '';
3696             }
3697             else {
3698 0         0 my $fh = gensym();
3699 0 0       0 if (_open_r($fh, $_)) {
3700 0         0 my $o = -o $fh;
3701 0 0       0 close($fh) or die "Can't close file: $_: $!";
3702 0 0       0 return $o ? 1 : '';
3703             }
3704             }
3705             }
3706 0         0 return undef;
3707             }
3708              
3709             #
3710             # KPS9566 file test -R $_
3711             #
3712             sub Ekps9566::R_() {
3713              
3714 0 0   0 0 0 if (-e $_) {
    0          
3715 0 0       0 return -R _ ? 1 : '';
3716             }
3717             elsif (_MSWin32_5Cended_path($_)) {
3718 0 0       0 if (-d "$_/.") {
3719 0 0       0 return -R _ ? 1 : '';
3720             }
3721             else {
3722 0         0 my $fh = gensym();
3723 0 0       0 if (_open_r($fh, $_)) {
3724 0         0 my $R = -R $fh;
3725 0 0       0 close($fh) or die "Can't close file: $_: $!";
3726 0 0       0 return $R ? 1 : '';
3727             }
3728             }
3729             }
3730 0         0 return undef;
3731             }
3732              
3733             #
3734             # KPS9566 file test -W $_
3735             #
3736             sub Ekps9566::W_() {
3737              
3738 0 0   0 0 0 if (-e $_) {
    0          
3739 0 0       0 return -W _ ? 1 : '';
3740             }
3741             elsif (_MSWin32_5Cended_path($_)) {
3742 0 0       0 if (-d "$_/.") {
3743 0 0       0 return -W _ ? 1 : '';
3744             }
3745             else {
3746 0         0 my $fh = gensym();
3747 0 0       0 if (_open_a($fh, $_)) {
3748 0         0 my $W = -W $fh;
3749 0 0       0 close($fh) or die "Can't close file: $_: $!";
3750 0 0       0 return $W ? 1 : '';
3751             }
3752             }
3753             }
3754 0         0 return undef;
3755             }
3756              
3757             #
3758             # KPS9566 file test -X $_
3759             #
3760             sub Ekps9566::X_() {
3761              
3762 0 0   0 0 0 if (-e $_) {
    0          
3763 0 0       0 return -X _ ? 1 : '';
3764             }
3765             elsif (_MSWin32_5Cended_path($_)) {
3766 0 0       0 if (-d "$_/.") {
3767 0 0       0 return -X _ ? 1 : '';
3768             }
3769             else {
3770 0         0 my $fh = gensym();
3771 0 0       0 if (_open_r($fh, $_)) {
3772 0         0 my $dummy_for_underline_cache = -X $fh;
3773 0 0       0 close($fh) or die "Can't close file: $_: $!";
3774             }
3775              
3776             # filename is not .COM .EXE .BAT .CMD
3777 0         0 return '';
3778             }
3779             }
3780 0         0 return undef;
3781             }
3782              
3783             #
3784             # KPS9566 file test -O $_
3785             #
3786             sub Ekps9566::O_() {
3787              
3788 0 0   0 0 0 if (-e $_) {
    0          
3789 0 0       0 return -O _ ? 1 : '';
3790             }
3791             elsif (_MSWin32_5Cended_path($_)) {
3792 0 0       0 if (-d "$_/.") {
3793 0 0       0 return -O _ ? 1 : '';
3794             }
3795             else {
3796 0         0 my $fh = gensym();
3797 0 0       0 if (_open_r($fh, $_)) {
3798 0         0 my $O = -O $fh;
3799 0 0       0 close($fh) or die "Can't close file: $_: $!";
3800 0 0       0 return $O ? 1 : '';
3801             }
3802             }
3803             }
3804 0         0 return undef;
3805             }
3806              
3807             #
3808             # KPS9566 file test -e $_
3809             #
3810             sub Ekps9566::e_() {
3811              
3812 0 0   0 0 0 if (-e $_) {
    0          
3813 0         0 return 1;
3814             }
3815             elsif (_MSWin32_5Cended_path($_)) {
3816 0 0       0 if (-d "$_/.") {
3817 0         0 return 1;
3818             }
3819             else {
3820 0         0 my $fh = gensym();
3821 0 0       0 if (_open_r($fh, $_)) {
3822 0         0 my $e = -e $fh;
3823 0 0       0 close($fh) or die "Can't close file: $_: $!";
3824 0 0       0 return $e ? 1 : '';
3825             }
3826             }
3827             }
3828 0         0 return undef;
3829             }
3830              
3831             #
3832             # KPS9566 file test -z $_
3833             #
3834             sub Ekps9566::z_() {
3835              
3836 0 0   0 0 0 if (-e $_) {
    0          
3837 0 0       0 return -z _ ? 1 : '';
3838             }
3839             elsif (_MSWin32_5Cended_path($_)) {
3840 0 0       0 if (-d "$_/.") {
3841 0 0       0 return -z _ ? 1 : '';
3842             }
3843             else {
3844 0         0 my $fh = gensym();
3845 0 0       0 if (_open_r($fh, $_)) {
3846 0         0 my $z = -z $fh;
3847 0 0       0 close($fh) or die "Can't close file: $_: $!";
3848 0 0       0 return $z ? 1 : '';
3849             }
3850             }
3851             }
3852 0         0 return undef;
3853             }
3854              
3855             #
3856             # KPS9566 file test -s $_
3857             #
3858             sub Ekps9566::s_() {
3859              
3860 0 0   0 0 0 if (-e $_) {
    0          
3861 0         0 return -s _;
3862             }
3863             elsif (_MSWin32_5Cended_path($_)) {
3864 0 0       0 if (-d "$_/.") {
3865 0         0 return -s _;
3866             }
3867             else {
3868 0         0 my $fh = gensym();
3869 0 0       0 if (_open_r($fh, $_)) {
3870 0         0 my $s = -s $fh;
3871 0 0       0 close($fh) or die "Can't close file: $_: $!";
3872 0         0 return $s;
3873             }
3874             }
3875             }
3876 0         0 return undef;
3877             }
3878              
3879             #
3880             # KPS9566 file test -f $_
3881             #
3882             sub Ekps9566::f_() {
3883              
3884 0 0   0 0 0 if (-e $_) {
    0          
3885 0 0       0 return -f _ ? 1 : '';
3886             }
3887             elsif (_MSWin32_5Cended_path($_)) {
3888 0 0       0 if (-d "$_/.") {
3889 0         0 return '';
3890             }
3891             else {
3892 0         0 my $fh = gensym();
3893 0 0       0 if (_open_r($fh, $_)) {
3894 0         0 my $f = -f $fh;
3895 0 0       0 close($fh) or die "Can't close file: $_: $!";
3896 0 0       0 return $f ? 1 : '';
3897             }
3898             }
3899             }
3900 0         0 return undef;
3901             }
3902              
3903             #
3904             # KPS9566 file test -d $_
3905             #
3906             sub Ekps9566::d_() {
3907              
3908 0 0   0 0 0 if (-e $_) {
    0          
3909 0 0       0 return -d _ ? 1 : '';
3910             }
3911             elsif (_MSWin32_5Cended_path($_)) {
3912 0 0       0 return -d "$_/." ? 1 : '';
3913             }
3914 0         0 return undef;
3915             }
3916              
3917             #
3918             # KPS9566 file test -l $_
3919             #
3920             sub Ekps9566::l_() {
3921              
3922 0 0   0 0 0 if (-e $_) {
    0          
3923 0 0       0 return -l _ ? 1 : '';
3924             }
3925             elsif (_MSWin32_5Cended_path($_)) {
3926 0 0       0 if (-d "$_/.") {
3927 0 0       0 return -l _ ? 1 : '';
3928             }
3929             else {
3930 0         0 my $fh = gensym();
3931 0 0       0 if (_open_r($fh, $_)) {
3932 0         0 my $l = -l $fh;
3933 0 0       0 close($fh) or die "Can't close file: $_: $!";
3934 0 0       0 return $l ? 1 : '';
3935             }
3936             }
3937             }
3938 0         0 return undef;
3939             }
3940              
3941             #
3942             # KPS9566 file test -p $_
3943             #
3944             sub Ekps9566::p_() {
3945              
3946 0 0   0 0 0 if (-e $_) {
    0          
3947 0 0       0 return -p _ ? 1 : '';
3948             }
3949             elsif (_MSWin32_5Cended_path($_)) {
3950 0 0       0 if (-d "$_/.") {
3951 0 0       0 return -p _ ? 1 : '';
3952             }
3953             else {
3954 0         0 my $fh = gensym();
3955 0 0       0 if (_open_r($fh, $_)) {
3956 0         0 my $p = -p $fh;
3957 0 0       0 close($fh) or die "Can't close file: $_: $!";
3958 0 0       0 return $p ? 1 : '';
3959             }
3960             }
3961             }
3962 0         0 return undef;
3963             }
3964              
3965             #
3966             # KPS9566 file test -S $_
3967             #
3968             sub Ekps9566::S_() {
3969              
3970 0 0   0 0 0 if (-e $_) {
    0          
3971 0 0       0 return -S _ ? 1 : '';
3972             }
3973             elsif (_MSWin32_5Cended_path($_)) {
3974 0 0       0 if (-d "$_/.") {
3975 0 0       0 return -S _ ? 1 : '';
3976             }
3977             else {
3978 0         0 my $fh = gensym();
3979 0 0       0 if (_open_r($fh, $_)) {
3980 0         0 my $S = -S $fh;
3981 0 0       0 close($fh) or die "Can't close file: $_: $!";
3982 0 0       0 return $S ? 1 : '';
3983             }
3984             }
3985             }
3986 0         0 return undef;
3987             }
3988              
3989             #
3990             # KPS9566 file test -b $_
3991             #
3992             sub Ekps9566::b_() {
3993              
3994 0 0   0 0 0 if (-e $_) {
    0          
3995 0 0       0 return -b _ ? 1 : '';
3996             }
3997             elsif (_MSWin32_5Cended_path($_)) {
3998 0 0       0 if (-d "$_/.") {
3999 0 0       0 return -b _ ? 1 : '';
4000             }
4001             else {
4002 0         0 my $fh = gensym();
4003 0 0       0 if (_open_r($fh, $_)) {
4004 0         0 my $b = -b $fh;
4005 0 0       0 close($fh) or die "Can't close file: $_: $!";
4006 0 0       0 return $b ? 1 : '';
4007             }
4008             }
4009             }
4010 0         0 return undef;
4011             }
4012              
4013             #
4014             # KPS9566 file test -c $_
4015             #
4016             sub Ekps9566::c_() {
4017              
4018 0 0   0 0 0 if (-e $_) {
    0          
4019 0 0       0 return -c _ ? 1 : '';
4020             }
4021             elsif (_MSWin32_5Cended_path($_)) {
4022 0 0       0 if (-d "$_/.") {
4023 0 0       0 return -c _ ? 1 : '';
4024             }
4025             else {
4026 0         0 my $fh = gensym();
4027 0 0       0 if (_open_r($fh, $_)) {
4028 0         0 my $c = -c $fh;
4029 0 0       0 close($fh) or die "Can't close file: $_: $!";
4030 0 0       0 return $c ? 1 : '';
4031             }
4032             }
4033             }
4034 0         0 return undef;
4035             }
4036              
4037             #
4038             # KPS9566 file test -u $_
4039             #
4040             sub Ekps9566::u_() {
4041              
4042 0 0   0 0 0 if (-e $_) {
    0          
4043 0 0       0 return -u _ ? 1 : '';
4044             }
4045             elsif (_MSWin32_5Cended_path($_)) {
4046 0 0       0 if (-d "$_/.") {
4047 0 0       0 return -u _ ? 1 : '';
4048             }
4049             else {
4050 0         0 my $fh = gensym();
4051 0 0       0 if (_open_r($fh, $_)) {
4052 0         0 my $u = -u $fh;
4053 0 0       0 close($fh) or die "Can't close file: $_: $!";
4054 0 0       0 return $u ? 1 : '';
4055             }
4056             }
4057             }
4058 0         0 return undef;
4059             }
4060              
4061             #
4062             # KPS9566 file test -g $_
4063             #
4064             sub Ekps9566::g_() {
4065              
4066 0 0   0 0 0 if (-e $_) {
    0          
4067 0 0       0 return -g _ ? 1 : '';
4068             }
4069             elsif (_MSWin32_5Cended_path($_)) {
4070 0 0       0 if (-d "$_/.") {
4071 0 0       0 return -g _ ? 1 : '';
4072             }
4073             else {
4074 0         0 my $fh = gensym();
4075 0 0       0 if (_open_r($fh, $_)) {
4076 0         0 my $g = -g $fh;
4077 0 0       0 close($fh) or die "Can't close file: $_: $!";
4078 0 0       0 return $g ? 1 : '';
4079             }
4080             }
4081             }
4082 0         0 return undef;
4083             }
4084              
4085             #
4086             # KPS9566 file test -k $_
4087             #
4088             sub Ekps9566::k_() {
4089              
4090 0 0   0 0 0 if ($] =~ /^5\.008/oxms) {
4091 0 0       0 return wantarray ? ('',@_) : '';
4092             }
4093 0 0       0 return wantarray ? ($_,@_) : $_;
4094             }
4095              
4096             #
4097             # KPS9566 file test -T $_
4098             #
4099             sub Ekps9566::T_() {
4100              
4101 0     0 0 0 my $T = 1;
4102              
4103 0 0 0     0 if (-d $_ or -d "$_/.") {
4104 0         0 return undef;
4105             }
4106 0         0 my $fh = gensym();
4107 0 0       0 if (_open_r($fh, $_)) {
4108             }
4109             else {
4110 0         0 return undef;
4111             }
4112              
4113 0 0       0 if (sysread $fh, my $block, 512) {
4114 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4115 0         0 $T = '';
4116             }
4117             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4118 0         0 $T = '';
4119             }
4120             }
4121              
4122             # 0 byte or eof
4123             else {
4124 0         0 $T = 1;
4125             }
4126 0         0 my $dummy_for_underline_cache = -T $fh;
4127 0 0       0 close($fh) or die "Can't close file: $_: $!";
4128              
4129 0         0 return $T;
4130             }
4131              
4132             #
4133             # KPS9566 file test -B $_
4134             #
4135             sub Ekps9566::B_() {
4136              
4137 0     0 0 0 my $B = '';
4138              
4139 0 0 0     0 if (-d $_ or -d "$_/.") {
4140 0         0 return undef;
4141             }
4142 0         0 my $fh = gensym();
4143 0 0       0 if (_open_r($fh, $_)) {
4144             }
4145             else {
4146 0         0 return undef;
4147             }
4148              
4149 0 0       0 if (sysread $fh, my $block, 512) {
4150 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4151 0         0 $B = 1;
4152             }
4153             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4154 0         0 $B = 1;
4155             }
4156             }
4157              
4158             # 0 byte or eof
4159             else {
4160 0         0 $B = 1;
4161             }
4162 0         0 my $dummy_for_underline_cache = -B $fh;
4163 0 0       0 close($fh) or die "Can't close file: $_: $!";
4164              
4165 0         0 return $B;
4166             }
4167              
4168             #
4169             # KPS9566 file test -M $_
4170             #
4171             sub Ekps9566::M_() {
4172              
4173 0 0   0 0 0 if (-e $_) {
    0          
4174 0         0 return -M _;
4175             }
4176             elsif (_MSWin32_5Cended_path($_)) {
4177 0 0       0 if (-d "$_/.") {
4178 0         0 return -M _;
4179             }
4180             else {
4181 0         0 my $fh = gensym();
4182 0 0       0 if (_open_r($fh, $_)) {
4183 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4184 0 0       0 close($fh) or die "Can't close file: $_: $!";
4185 0         0 my $M = ($^T - $mtime) / (24*60*60);
4186 0         0 return $M;
4187             }
4188             }
4189             }
4190 0         0 return undef;
4191             }
4192              
4193             #
4194             # KPS9566 file test -A $_
4195             #
4196             sub Ekps9566::A_() {
4197              
4198 0 0   0 0 0 if (-e $_) {
    0          
4199 0         0 return -A _;
4200             }
4201             elsif (_MSWin32_5Cended_path($_)) {
4202 0 0       0 if (-d "$_/.") {
4203 0         0 return -A _;
4204             }
4205             else {
4206 0         0 my $fh = gensym();
4207 0 0       0 if (_open_r($fh, $_)) {
4208 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4209 0 0       0 close($fh) or die "Can't close file: $_: $!";
4210 0         0 my $A = ($^T - $atime) / (24*60*60);
4211 0         0 return $A;
4212             }
4213             }
4214             }
4215 0         0 return undef;
4216             }
4217              
4218             #
4219             # KPS9566 file test -C $_
4220             #
4221             sub Ekps9566::C_() {
4222              
4223 0 0   0 0 0 if (-e $_) {
    0          
4224 0         0 return -C _;
4225             }
4226             elsif (_MSWin32_5Cended_path($_)) {
4227 0 0       0 if (-d "$_/.") {
4228 0         0 return -C _;
4229             }
4230             else {
4231 0         0 my $fh = gensym();
4232 0 0       0 if (_open_r($fh, $_)) {
4233 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4234 0 0       0 close($fh) or die "Can't close file: $_: $!";
4235 0         0 my $C = ($^T - $ctime) / (24*60*60);
4236 0         0 return $C;
4237             }
4238             }
4239             }
4240 0         0 return undef;
4241             }
4242              
4243             #
4244             # KPS9566 path globbing (with parameter)
4245             #
4246             sub Ekps9566::glob($) {
4247              
4248 0 0   0 0 0 if (wantarray) {
4249 0         0 my @glob = _DOS_like_glob(@_);
4250 0         0 for my $glob (@glob) {
4251 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4252             }
4253 0         0 return @glob;
4254             }
4255             else {
4256 0         0 my $glob = _DOS_like_glob(@_);
4257 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4258 0         0 return $glob;
4259             }
4260             }
4261              
4262             #
4263             # KPS9566 path globbing (without parameter)
4264             #
4265             sub Ekps9566::glob_() {
4266              
4267 0 0   0 0 0 if (wantarray) {
4268 0         0 my @glob = _DOS_like_glob();
4269 0         0 for my $glob (@glob) {
4270 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4271             }
4272 0         0 return @glob;
4273             }
4274             else {
4275 0         0 my $glob = _DOS_like_glob();
4276 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4277 0         0 return $glob;
4278             }
4279             }
4280              
4281             #
4282             # KPS9566 path globbing via File::DosGlob 1.10
4283             #
4284             # Often I confuse "_dosglob" and "_doglob".
4285             # So, I renamed "_dosglob" to "_DOS_like_glob".
4286             #
4287             my %iter;
4288             my %entries;
4289             sub _DOS_like_glob {
4290              
4291             # context (keyed by second cxix argument provided by core)
4292 0     0   0 my($expr,$cxix) = @_;
4293              
4294             # glob without args defaults to $_
4295 0 0       0 $expr = $_ if not defined $expr;
4296              
4297             # represents the current user's home directory
4298             #
4299             # 7.3. Expanding Tildes in Filenames
4300             # in Chapter 7. File Access
4301             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4302             #
4303             # and File::HomeDir, File::HomeDir::Windows module
4304              
4305             # DOS-like system
4306 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4307 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
4308             { my_home_MSWin32() }oxmse;
4309             }
4310              
4311             # UNIX-like system
4312 0 0 0     0 else {
  0         0  
4313             $expr =~ s{ \A ~ ( (?:[^\x81-\xFE/]|[\x81-\xFE][\x00-\xFF])* ) }
4314             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
4315             }
4316 0 0       0  
4317 0 0       0 # assume global context if not provided one
4318             $cxix = '_G_' if not defined $cxix;
4319             $iter{$cxix} = 0 if not exists $iter{$cxix};
4320 0 0       0  
4321 0         0 # if we're just beginning, do it all first
4322             if ($iter{$cxix} == 0) {
4323             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
4324             }
4325 0 0       0  
4326 0         0 # chuck it all out, quick or slow
4327 0         0 if (wantarray) {
  0         0  
4328             delete $iter{$cxix};
4329             return @{delete $entries{$cxix}};
4330 0 0       0 }
  0         0  
4331 0         0 else {
  0         0  
4332             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
4333             return shift @{$entries{$cxix}};
4334             }
4335 0         0 else {
4336 0         0 # return undef for EOL
4337 0         0 delete $iter{$cxix};
4338             delete $entries{$cxix};
4339             return undef;
4340             }
4341             }
4342             }
4343              
4344             #
4345             # KPS9566 path globbing subroutine
4346             #
4347 0     0   0 sub _do_glob {
4348 0         0  
4349 0         0 my($cond,@expr) = @_;
4350             my @glob = ();
4351             my $fix_drive_relative_paths = 0;
4352 0         0  
4353 0 0       0 OUTER:
4354 0 0       0 for my $expr (@expr) {
4355             next OUTER if not defined $expr;
4356 0         0 next OUTER if $expr eq '';
4357 0         0  
4358 0         0 my @matched = ();
4359 0         0 my @globdir = ();
4360 0         0 my $head = '.';
4361             my $pathsep = '/';
4362             my $tail;
4363 0 0       0  
4364 0         0 # if argument is within quotes strip em and do no globbing
4365 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
4366 0 0       0 $expr = $1;
4367 0         0 if ($cond eq 'd') {
4368             if (Ekps9566::d $expr) {
4369             push @glob, $expr;
4370             }
4371 0 0       0 }
4372 0         0 else {
4373             if (Ekps9566::e $expr) {
4374             push @glob, $expr;
4375 0         0 }
4376             }
4377             next OUTER;
4378             }
4379              
4380 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
4381 0 0       0 # to h:./*.pm to expand correctly
4382 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4383             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^\x81-\xFE/\\]|[\x81-\xFE][\x00-\xFF]) #$1./$2#oxms) {
4384             $fix_drive_relative_paths = 1;
4385             }
4386 0 0       0 }
4387 0 0       0  
4388 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
4389 0         0 if ($tail eq '') {
4390             push @glob, $expr;
4391 0 0       0 next OUTER;
4392 0 0       0 }
4393 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
4394 0         0 if (@globdir = _do_glob('d', $head)) {
4395             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
4396             next OUTER;
4397 0 0 0     0 }
4398 0         0 }
4399             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
4400 0         0 $head .= $pathsep;
4401             }
4402             $expr = $tail;
4403             }
4404 0 0       0  
4405 0 0       0 # If file component has no wildcards, we can avoid opendir
4406 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
4407             if ($head eq '.') {
4408 0 0 0     0 $head = '';
4409 0         0 }
4410             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4411 0         0 $head .= $pathsep;
4412 0 0       0 }
4413 0 0       0 $head .= $expr;
4414 0         0 if ($cond eq 'd') {
4415             if (Ekps9566::d $head) {
4416             push @glob, $head;
4417             }
4418 0 0       0 }
4419 0         0 else {
4420             if (Ekps9566::e $head) {
4421             push @glob, $head;
4422 0         0 }
4423             }
4424 0 0       0 next OUTER;
4425 0         0 }
4426 0         0 Ekps9566::opendir(*DIR, $head) or next OUTER;
4427             my @leaf = readdir DIR;
4428 0 0       0 closedir DIR;
4429 0         0  
4430             if ($head eq '.') {
4431 0 0 0     0 $head = '';
4432 0         0 }
4433             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4434             $head .= $pathsep;
4435 0         0 }
4436 0         0  
4437 0         0 my $pattern = '';
4438             while ($expr =~ / \G ($q_char) /oxgc) {
4439             my $char = $1;
4440              
4441             # 6.9. Matching Shell Globs as Regular Expressions
4442             # in Chapter 6. Pattern Matching
4443             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4444 0 0       0 # (and so on)
    0          
    0          
4445 0         0  
4446             if ($char eq '*') {
4447             $pattern .= "(?:$your_char)*",
4448 0         0 }
4449             elsif ($char eq '?') {
4450             $pattern .= "(?:$your_char)?", # DOS style
4451             # $pattern .= "(?:$your_char)", # UNIX style
4452 0         0 }
4453             elsif ((my $fc = Ekps9566::fc($char)) ne $char) {
4454             $pattern .= $fc;
4455 0         0 }
4456             else {
4457             $pattern .= quotemeta $char;
4458 0     0   0 }
  0         0  
4459             }
4460             my $matchsub = sub { Ekps9566::fc($_[0]) =~ /\A $pattern \z/xms };
4461              
4462             # if ($@) {
4463             # print STDERR "$0: $@\n";
4464             # next OUTER;
4465             # }
4466 0         0  
4467 0 0 0     0 INNER:
4468 0         0 for my $leaf (@leaf) {
4469             if ($leaf eq '.' or $leaf eq '..') {
4470 0 0 0     0 next INNER;
4471 0         0 }
4472             if ($cond eq 'd' and not Ekps9566::d "$head$leaf") {
4473             next INNER;
4474 0 0       0 }
4475 0         0  
4476 0         0 if (&$matchsub($leaf)) {
4477             push @matched, "$head$leaf";
4478             next INNER;
4479             }
4480              
4481             # [DOS compatibility special case]
4482 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
4483              
4484             if (Ekps9566::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
4485             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
4486 0 0       0 Ekps9566::index($pattern,'\\.') != -1 # pattern has a dot.
4487 0         0 ) {
4488 0         0 if (&$matchsub("$leaf.")) {
4489             push @matched, "$head$leaf";
4490             next INNER;
4491             }
4492 0 0       0 }
4493 0         0 }
4494             if (@matched) {
4495             push @glob, @matched;
4496 0 0       0 }
4497 0         0 }
4498 0         0 if ($fix_drive_relative_paths) {
4499             for my $glob (@glob) {
4500             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
4501 0         0 }
4502             }
4503             return @glob;
4504             }
4505              
4506             #
4507             # KPS9566 parse line
4508             #
4509 0     0   0 sub _parse_line {
4510              
4511 0         0 my($line) = @_;
4512 0         0  
4513 0         0 $line .= ' ';
4514             my @piece = ();
4515             while ($line =~ /
4516             " ( (?>(?: [^\x81-\xFE"] |[\x81-\xFE][\x00-\xFF] )* ) ) " (?>\s+) |
4517             ( (?>(?: [^\x81-\xFE"\s]|[\x81-\xFE][\x00-\xFF] )* ) ) (?>\s+)
4518 0 0       0 /oxmsg
4519             ) {
4520 0         0 push @piece, defined($1) ? $1 : $2;
4521             }
4522             return @piece;
4523             }
4524              
4525             #
4526             # KPS9566 parse path
4527             #
4528 0     0   0 sub _parse_path {
4529              
4530 0         0 my($path,$pathsep) = @_;
4531 0         0  
4532 0         0 $path .= '/';
4533             my @subpath = ();
4534             while ($path =~ /
4535             ((?: [^\x81-\xFE\/\\]|[\x81-\xFE][\x00-\xFF] )+?) [\/\\]
4536 0         0 /oxmsg
4537             ) {
4538             push @subpath, $1;
4539 0         0 }
4540 0         0  
4541 0         0 my $tail = pop @subpath;
4542             my $head = join $pathsep, @subpath;
4543             return $head, $tail;
4544             }
4545              
4546             #
4547             # via File::HomeDir::Windows 1.00
4548             #
4549             sub my_home_MSWin32 {
4550              
4551             # A lot of unix people and unix-derived tools rely on
4552 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
4553 0         0 # so that they can replace raw HOME calls with File::HomeDir.
4554             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
4555             return $ENV{'HOME'};
4556             }
4557              
4558 0         0 # Do we have a user profile?
4559             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
4560             return $ENV{'USERPROFILE'};
4561             }
4562              
4563 0         0 # Some Windows use something like $ENV{'HOME'}
4564             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
4565             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
4566 0         0 }
4567              
4568             return undef;
4569             }
4570              
4571             #
4572             # via File::HomeDir::Unix 1.00
4573 0     0 0 0 #
4574             sub my_home {
4575 0 0 0     0 my $home;
    0 0        
4576 0         0  
4577             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
4578             $home = $ENV{'HOME'};
4579             }
4580              
4581             # This is from the original code, but I'm guessing
4582 0         0 # it means "login directory" and exists on some Unixes.
4583             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
4584             $home = $ENV{'LOGDIR'};
4585             }
4586              
4587             ### More-desperate methods
4588              
4589 0         0 # Light desperation on any (Unixish) platform
4590             else {
4591             $home = CORE::eval q{ (getpwuid($<))[7] };
4592             }
4593              
4594 0 0 0     0 # On Unix in general, a non-existant home means "no home"
4595 0         0 # For example, "nobody"-like users might use /nonexistant
4596             if (defined $home and ! Ekps9566::d($home)) {
4597 0         0 $home = undef;
4598             }
4599             return $home;
4600             }
4601              
4602             #
4603             # KPS9566 file lstat (with parameter)
4604             #
4605 0 0   0 0 0 sub Ekps9566::lstat(*) {
4606              
4607 0 0       0 local $_ = shift if @_;
    0          
4608 0         0  
4609             if (-e $_) {
4610             return CORE::lstat _;
4611             }
4612             elsif (_MSWin32_5Cended_path($_)) {
4613              
4614             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Ekps9566::lstat()
4615             # on Windows opens the file for the path which has 5c at end.
4616 0         0 # (and so on)
4617 0 0       0  
4618 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4619 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4620 0 0       0 if (wantarray) {
4621 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4622             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4623             return @stat;
4624 0         0 }
4625 0 0       0 else {
4626 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4627             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4628             return $stat;
4629             }
4630 0 0       0 }
4631             }
4632             return wantarray ? () : undef;
4633             }
4634              
4635             #
4636             # KPS9566 file lstat (without parameter)
4637             #
4638 0 0   0 0 0 sub Ekps9566::lstat_() {
    0          
4639 0         0  
4640             if (-e $_) {
4641             return CORE::lstat _;
4642 0         0 }
4643 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4644 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4645 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4646 0 0       0 if (wantarray) {
4647 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4648             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4649             return @stat;
4650 0         0 }
4651 0 0       0 else {
4652 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4653             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4654             return $stat;
4655             }
4656 0 0       0 }
4657             }
4658             return wantarray ? () : undef;
4659             }
4660              
4661             #
4662             # KPS9566 path opendir
4663             #
4664 0     0 0 0 sub Ekps9566::opendir(*$) {
4665 0 0       0  
    0          
4666 0         0 my $dh = qualify_to_ref $_[0];
4667             if (CORE::opendir $dh, $_[1]) {
4668             return 1;
4669 0 0       0 }
4670 0         0 elsif (_MSWin32_5Cended_path($_[1])) {
4671             if (CORE::opendir $dh, "$_[1]/.") {
4672             return 1;
4673 0         0 }
4674             }
4675             return undef;
4676             }
4677              
4678             #
4679             # KPS9566 file stat (with parameter)
4680             #
4681 0 50   382 0 0 sub Ekps9566::stat(*) {
4682              
4683 382         2750 local $_ = shift if @_;
4684 382 50       2443  
    50          
    0          
4685 382         13017 my $fh = qualify_to_ref $_;
4686             if (defined fileno $fh) {
4687             return CORE::stat $fh;
4688 0         0 }
4689             elsif (-e $_) {
4690             return CORE::stat _;
4691             }
4692             elsif (_MSWin32_5Cended_path($_)) {
4693              
4694             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Ekps9566::stat()
4695             # on Windows opens the file for the path which has 5c at end.
4696 382         3085 # (and so on)
4697 0 0       0  
4698 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4699 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4700 0 0       0 if (wantarray) {
4701 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4702             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4703             return @stat;
4704 0         0 }
4705 0 0       0 else {
4706 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4707             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4708             return $stat;
4709             }
4710 0 0       0 }
4711             }
4712             return wantarray ? () : undef;
4713             }
4714              
4715             #
4716             # KPS9566 file stat (without parameter)
4717             #
4718 0     0 0 0 sub Ekps9566::stat_() {
4719 0 0       0  
    0          
    0          
4720 0         0 my $fh = qualify_to_ref $_;
4721             if (defined fileno $fh) {
4722             return CORE::stat $fh;
4723 0         0 }
4724             elsif (-e $_) {
4725             return CORE::stat _;
4726 0         0 }
4727 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4728 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4729 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4730 0 0       0 if (wantarray) {
4731 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4732             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4733             return @stat;
4734 0         0 }
4735 0 0       0 else {
4736 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4737             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4738             return $stat;
4739             }
4740 0 0       0 }
4741             }
4742             return wantarray ? () : undef;
4743             }
4744              
4745             #
4746             # KPS9566 path unlink
4747             #
4748 0 0   0 0 0 sub Ekps9566::unlink(@) {
4749              
4750 0         0 local @_ = ($_) unless @_;
4751 0         0  
4752 0 0       0 my $unlink = 0;
    0          
    0          
4753 0         0 for (@_) {
4754             if (CORE::unlink) {
4755             $unlink++;
4756             }
4757             elsif (Ekps9566::d($_)) {
4758 0         0 }
4759 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
  0         0  
4760 0 0       0 my @char = /\G (?>$q_char) /oxmsg;
4761 0         0 my $file = join '', map {{'/' => '\\'}->{$_} || $_} @char;
4762             if ($file =~ / \A (?:$q_char)*? [ ] /oxms) {
4763 0         0 $file = qq{"$file"};
4764 0 0       0 }
4765 0 0       0 my $fh = gensym();
4766             if (_open_r($fh, $_)) {
4767             close($fh) or die "Can't close file: $_: $!";
4768 0 0 0     0  
    0          
4769 0         0 # cmd.exe on Windows NT, Windows 2000, Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
4770             if ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
4771             CORE::system 'DEL', '/F', $file, '2>NUL';
4772             }
4773              
4774 0         0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
4775             elsif (qx{ver} =~ /\b(?:Windows 2000)\b/oms) {
4776             CORE::system 'DEL', '/F', $file, '2>NUL';
4777             }
4778              
4779             # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
4780 0         0 # command.com can not "2>NUL"
4781 0         0 else {
4782             CORE::system 'ATTRIB', '-R', $file; # clears Read-only file attribute
4783             CORE::system 'DEL', $file;
4784 0 0       0 }
4785 0 0       0  
4786             if (_open_r($fh, $_)) {
4787             close($fh) or die "Can't close file: $_: $!";
4788 0         0 }
4789             else {
4790             $unlink++;
4791             }
4792             }
4793 0         0 }
4794             }
4795             return $unlink;
4796             }
4797              
4798             #
4799             # KPS9566 chdir
4800             #
4801 0 0   0 0 0 sub Ekps9566::chdir(;$) {
4802 0         0  
4803             if (@_ == 0) {
4804             return CORE::chdir;
4805 0         0 }
4806              
4807 0 0       0 my($dir) = @_;
4808 0 0       0  
4809 0         0 if (_MSWin32_5Cended_path($dir)) {
4810             if (not Ekps9566::d $dir) {
4811             return 0;
4812 0 0 0     0 }
    0          
4813 0         0  
4814             if ($] =~ /^5\.005/oxms) {
4815             return CORE::chdir $dir;
4816 0         0 }
4817 0         0 elsif (($] =~ /^(?:5\.006|5\.008000)/oxms) and ($^O eq 'MSWin32')) {
4818             local $@;
4819             my $chdir = CORE::eval q{
4820             CORE::require 'jacode.pl';
4821              
4822             # P.676 ${^WIDE_SYSTEM_CALLS}
4823             # in Chapter 28: Special Names
4824             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4825              
4826             # P.790 ${^WIDE_SYSTEM_CALLS}
4827             # in Chapter 25: Special Names
4828             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4829              
4830             local ${^WIDE_SYSTEM_CALLS} = 1;
4831 0 0       0 return CORE::chdir jcode::utf8($dir,'sjis');
4832 0         0 };
4833             if (not $@) {
4834             return $chdir;
4835             }
4836             }
4837              
4838             # old idea (Win32 module required)
4839             elsif (0) {
4840             local $@;
4841             my $shortdir = '';
4842             my $chdir = CORE::eval q{
4843             use Win32;
4844             $shortdir = Win32::GetShortPathName($dir);
4845             if ($shortdir ne $dir) {
4846             return CORE::chdir $shortdir;
4847             }
4848             else {
4849             return 0;
4850             }
4851             };
4852             if ($@) {
4853             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4854             while ($char[-1] eq "\x5C") {
4855             pop @char;
4856             }
4857             $dir = join '', @char;
4858             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path), Win32.pm module may help you";
4859             }
4860             elsif ($shortdir eq $dir) {
4861             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4862             while ($char[-1] eq "\x5C") {
4863             pop @char;
4864             }
4865             $dir = join '', @char;
4866             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path)";
4867             }
4868             return $chdir;
4869             }
4870 0         0  
4871             # rejected idea ...
4872             elsif (0) {
4873              
4874             # MSDN SetCurrentDirectory function
4875             # http://msdn.microsoft.com/ja-jp/library/windows/desktop/aa365530(v=vs.85).aspx
4876             #
4877             # Data Execution Prevention (DEP)
4878             # http://vlaurie.com/computers2/Articles/dep.htm
4879             #
4880             # Learning x86 assembler with Perl -- Shibuya.pm#11
4881             # http://developer.cybozu.co.jp/takesako/2009/06/perl-x86-shibuy.html
4882             #
4883             # Introduction to Win32::API programming in Perl
4884             # http://d.hatena.ne.jp/TAKESAKO/20090324/1237879559
4885             #
4886             # DynaLoader - Dynamically load C libraries into Perl code
4887             # http://perldoc.perl.org/DynaLoader.html
4888             #
4889             # Basic knowledge of DynaLoader
4890             # http://blog.64p.org/entry/20090313/1236934042
4891              
4892             if (($] =~ /^5\.006/oxms) and
4893             ($^O eq 'MSWin32') and
4894             ($ENV{'PROCESSOR_ARCHITECTURE'} eq 'x86') and
4895             CORE::eval(q{CORE::require 'Dyna'.'Loader'})
4896             ) {
4897             my $x86 = join('',
4898              
4899             # PUSH Iv
4900             "\x68", pack('P', "$dir\\\0"),
4901              
4902             # MOV eAX, Iv
4903             "\xb8", pack('L',
4904             *{'Dyna'.'Loader::dl_find_symbol'}{'CODE'}->(
4905             *{'Dyna'.'Loader::dl_load_file'}{'CODE'}->("$ENV{'SystemRoot'}\\system32\\kernel32.dll"),
4906             'SetCurrentDirectoryA'
4907             )
4908             ),
4909              
4910             # CALL eAX
4911             "\xff\xd0",
4912              
4913             # RETN
4914             "\xc3",
4915             );
4916             *{'Dyna'.'Loader::dl_install_xsub'}{'CODE'}->('_SetCurrentDirectoryA', unpack('L', pack 'P', $x86));
4917             _SetCurrentDirectoryA();
4918             chomp(my $chdir = qx{chdir});
4919             if (Ekps9566::fc($chdir) eq Ekps9566::fc($dir)) {
4920             return 1;
4921             }
4922             else {
4923             return 0;
4924             }
4925             }
4926             }
4927              
4928             # COMMAND.COM's unhelpful tips:
4929             # Displays a list of files and subdirectories in a directory.
4930             # http://www.lagmonster.org/docs/DOS7/z-dir.html
4931             #
4932             # Syntax:
4933             #
4934             # DIR [drive:] [path] [filename] [/Switches]
4935             #
4936             # /Z Long file names are not displayed in the file listing
4937             #
4938             # Limitations
4939             # The undocumented /Z switch (no long names) would appear to
4940             # have been not fully developed and has a couple of problems:
4941             #
4942             # 1. It will only work if:
4943             # There is no path specified (ie. for the current directory in
4944             # the current drive)
4945             # The path is specified as the root directory of any drive
4946             # (eg. C:\, D:\, etc.)
4947             # The path is specified as the current directory of any drive
4948             # by using the drive letter only (eg. C:, D:, etc.)
4949             # The path is specified as the parent directory using the ..
4950             # notation (eg. DIR .. /Z)
4951             # Any other syntax results in a "File Not Found" error message.
4952             #
4953             # 2. The /Z switch is compatable with the /S switch to show
4954             # subdirectories (as long as the above rules are followed) and
4955             # all the files are shown with short names only. The
4956             # subdirectories are also shown with short names only. However,
4957             # the header for each subdirectory after the first level gives
4958             # the subdirectory's long name.
4959             #
4960             # 3. The /Z switch is also compatable with the /B switch to give
4961             # a simple list of files with short names only. When used with
4962             # the /S switch as well, all files are listed with their full
4963             # paths. The file names themselves are all in short form, and
4964             # the path of those files in the current directory are in short
4965             # form, but the paths of any files in subdirectories are in
4966 0         0 # long filename form.
4967 0         0  
4968 0         0 my $shortdir = '';
4969 0         0 my $i = 0;
4970 0         0 my @subdir = ();
4971 0 0 0     0 while ($dir =~ / \G ($q_char) /oxgc) {
4972 0         0 my $char = $1;
4973 0         0 if (($char eq '\\') or ($char eq '/')) {
4974 0         0 $i++;
4975             $subdir[$i] = $char;
4976             $i++;
4977 0         0 }
4978             else {
4979             $subdir[$i] .= $char;
4980 0 0 0     0 }
4981 0         0 }
4982             if (($subdir[-1] eq '\\') or ($subdir[-1] eq '/')) {
4983             pop @subdir;
4984             }
4985              
4986             # P.504 PERL5SHELL (Microsoft ports only)
4987             # in Chapter 19: The Command-Line Interface
4988             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4989              
4990             # P.597 PERL5SHELL (Microsoft ports only)
4991             # in Chapter 17: The Command-Line Interface
4992             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4993              
4994 0 0 0     0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
    0          
4995 0         0 # cmd.exe on Windows NT, Windows 2000
4996 0         0 if (qx{ver} =~ /\b(?:Windows NT|Windows 2000)\b/oms) {
  0         0  
4997 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
4998             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
4999             if (Ekps9566::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Ekps9566::fc($subdir[-1])) {
5000 0         0  
5001 0         0 # short file name (8dot3name) here-----vv
5002 0         0 my $shortleafdir = CORE::substr $dirx, 39, 8+1+3;
5003 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5004             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5005             last;
5006             }
5007             }
5008             }
5009              
5010             # an idea (not so portable, only Windows 2000 or later)
5011             elsif (0) {
5012             chomp($shortdir = qx{for %I in ("$dir") do \@echo %~sI 2>NUL});
5013             }
5014              
5015 0         0 # cmd.exe on Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
5016 0         0 elsif ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
  0         0  
5017 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5018             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5019             if (Ekps9566::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Ekps9566::fc($subdir[-1])) {
5020 0         0  
5021 0         0 # short file name (8dot3name) here-----vv
5022 0         0 my $shortleafdir = CORE::substr $dirx, 36, 8+1+3;
5023 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5024             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5025             last;
5026             }
5027             }
5028             }
5029              
5030 0         0 # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
5031 0         0 else {
  0         0  
5032 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad "$dir*"});
5033             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5034             if (Ekps9566::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Ekps9566::fc($subdir[-1])) {
5035 0         0  
5036 0         0 # short file name (8dot3name) here-----v
5037 0         0 my $shortleafdir = CORE::substr $dirx, 0, 8+1+3;
5038 0         0 CORE::substr($shortleafdir,8,1) = '.';
5039 0         0 $shortleafdir =~ s/ \. [ ]+ \z//oxms;
5040             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5041             last;
5042             }
5043             }
5044 0 0       0 }
    0          
5045 0         0  
5046             if ($shortdir eq '') {
5047             return 0;
5048 0         0 }
5049             elsif (Ekps9566::fc($shortdir) eq Ekps9566::fc($dir)) {
5050 0         0 return 0;
5051             }
5052             return CORE::chdir $shortdir;
5053 0         0 }
5054             else {
5055             return CORE::chdir $dir;
5056             }
5057             }
5058              
5059             #
5060             # KPS9566 chr(0x5C) ended path on MSWin32
5061             #
5062 0 50 33 764   0 sub _MSWin32_5Cended_path {
5063 764 50       5155  
5064 764         4125 if ((@_ >= 1) and ($_[0] ne '')) {
5065 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
5066 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5067             if ($char[-1] =~ / \x5C \z/oxms) {
5068             return 1;
5069             }
5070 0         0 }
5071             }
5072             return undef;
5073             }
5074              
5075             #
5076             # do KPS9566 file
5077             #
5078 764     0 0 2057 sub Ekps9566::do($) {
5079              
5080 0         0 my($filename) = @_;
5081              
5082             my $realfilename;
5083             my $result;
5084 0         0 ITER_DO:
  0         0  
5085 0 0       0 {
5086 0         0 for my $prefix (@INC) {
5087             if ($^O eq 'MacOS') {
5088             $realfilename = "$prefix$filename";
5089 0         0 }
5090             else {
5091             $realfilename = "$prefix/$filename";
5092 0 0       0 }
5093              
5094 0         0 if (Ekps9566::f($realfilename)) {
5095              
5096 0 0       0 my $script = '';
5097 0         0  
5098 0         0 if (Ekps9566::e("$realfilename.e")) {
5099 0         0 my $e_mtime = (Ekps9566::stat("$realfilename.e"))[9];
5100 0 0 0     0 my $mtime = (Ekps9566::stat($realfilename))[9];
5101 0         0 my $module_mtime = (Ekps9566::stat(__FILE__))[9];
5102             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5103             Ekps9566::unlink "$realfilename.e";
5104             }
5105 0 0       0 }
5106 0         0  
5107 0 0       0 if (Ekps9566::e("$realfilename.e")) {
5108 0 0       0 my $fh = gensym();
    0          
5109 0         0 if (_open_r($fh, "$realfilename.e")) {
5110             if ($^O eq 'MacOS') {
5111             CORE::eval q{
5112             CORE::require Mac::Files;
5113             Mac::Files::FSpSetFLock("$realfilename.e");
5114             };
5115             }
5116             elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5117              
5118             # P.419 File Locking
5119             # in Chapter 16: Interprocess Communication
5120             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5121              
5122             # P.524 File Locking
5123             # in Chapter 15: Interprocess Communication
5124             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5125              
5126 0         0 # (and so on)
5127 0 0       0  
5128 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5129             if ($@) {
5130             carp "Can't immediately read-lock the file: $realfilename.e";
5131             }
5132 0         0 }
5133             else {
5134 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5135 0         0 }
5136 0 0       0 local $/ = undef; # slurp mode
5137 0         0 $script = <$fh>;
5138             if ($^O eq 'MacOS') {
5139             CORE::eval q{
5140             CORE::require Mac::Files;
5141             Mac::Files::FSpRstFLock("$realfilename.e");
5142 0 0       0 };
5143             }
5144             close($fh) or die "Can't close file: $realfilename.e: $!";
5145             }
5146 0         0 }
5147 0 0       0 else {
5148 0 0       0 my $fh = gensym();
    0          
5149 0         0 if (_open_r($fh, $realfilename)) {
5150             if ($^O eq 'MacOS') {
5151             CORE::eval q{
5152             CORE::require Mac::Files;
5153             Mac::Files::FSpSetFLock($realfilename);
5154             };
5155 0         0 }
5156 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5157 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5158             if ($@) {
5159             carp "Can't immediately read-lock the file: $realfilename";
5160             }
5161 0         0 }
5162             else {
5163 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5164 0         0 }
5165 0 0       0 local $/ = undef; # slurp mode
5166 0         0 $script = <$fh>;
5167             if ($^O eq 'MacOS') {
5168             CORE::eval q{
5169             CORE::require Mac::Files;
5170             Mac::Files::FSpRstFLock($realfilename);
5171 0 0       0 };
5172             }
5173             close($fh) or die "Can't close file: $realfilename.e: $!";
5174 0 0       0 }
5175 0         0  
5176 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) KPS9566 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5177 0         0 CORE::require KPS9566;
5178 0 0       0 $script = KPS9566::escape_script($script);
5179 0 0       0 my $fh = gensym();
    0          
5180 0         0 open($fh, ">$realfilename.e") or die __FILE__, ": Can't write open file: $realfilename.e\n";
5181             if ($^O eq 'MacOS') {
5182             CORE::eval q{
5183             CORE::require Mac::Files;
5184             Mac::Files::FSpSetFLock("$realfilename.e");
5185             };
5186 0         0 }
5187 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5188 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5189             if ($@) {
5190             carp "Can't immediately write-lock the file: $realfilename.e";
5191             }
5192 0         0 }
5193             else {
5194 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5195 0 0       0 }
5196 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5197 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5198 0         0 print {$fh} $script;
5199             if ($^O eq 'MacOS') {
5200             CORE::eval q{
5201             CORE::require Mac::Files;
5202             Mac::Files::FSpRstFLock("$realfilename.e");
5203 0 0       0 };
5204             }
5205             close($fh) or die "Can't close file: $realfilename.e: $!";
5206             }
5207             }
5208 387     387   13601  
  387         5416  
  387         413257  
  0         0  
5209 0         0 {
5210             no strict;
5211 0         0 $result = scalar CORE::eval $script;
5212             }
5213             last ITER_DO;
5214             }
5215             }
5216 0 0       0 }
    0          
5217 0         0  
5218 0         0 if ($@) {
5219             $INC{$filename} = undef;
5220             return undef;
5221 0         0 }
5222             elsif (not $result) {
5223             return undef;
5224 0         0 }
5225 0         0 else {
5226             $INC{$filename} = $realfilename;
5227             return $result;
5228             }
5229             }
5230              
5231             #
5232             # require KPS9566 file
5233             #
5234              
5235             # require
5236             # in Chapter 3: Functions
5237             # of ISBN 1-56592-149-6 Programming Perl, Second Edition.
5238             #
5239             # sub require {
5240             # my($filename) = @_;
5241             # return 1 if $INC{$filename};
5242             # my($realfilename, $result);
5243             # ITER: {
5244             # foreach $prefix (@INC) {
5245             # $realfilename = "$prefix/$filename";
5246             # if (-f $realfilename) {
5247             # $result = CORE::eval `cat $realfilename`;
5248             # last ITER;
5249             # }
5250             # }
5251             # die "Can't find $filename in \@INC";
5252             # }
5253             # die $@ if $@;
5254             # die "$filename did not return true value" unless $result;
5255             # $INC{$filename} = $realfilename;
5256             # return $result;
5257             # }
5258              
5259             # require
5260             # in Chapter 9: perlfunc: Perl builtin functions
5261             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
5262             #
5263             # sub require {
5264             # my($filename) = @_;
5265             # if (exists $INC{$filename}) {
5266             # return 1 if $INC{$filename};
5267             # die "Compilation failed in require";
5268             # }
5269             # my($realfilename, $result);
5270             # ITER: {
5271             # foreach $prefix (@INC) {
5272             # $realfilename = "$prefix/$filename";
5273             # if (-f $realfilename) {
5274             # $INC{$filename} = $realfilename;
5275             # $result = do $realfilename;
5276             # last ITER;
5277             # }
5278             # }
5279             # die "Can't find $filename in \@INC";
5280             # }
5281             # if ($@) {
5282             # $INC{$filename} = undef;
5283             # die $@;
5284             # }
5285             # elsif (!$result) {
5286             # delete $INC{$filename};
5287             # die "$filename did not return true value";
5288             # }
5289             # else {
5290             # return $result;
5291             # }
5292             # }
5293              
5294 0 0   0 0 0 sub Ekps9566::require(;$) {
5295              
5296 0 0       0 local $_ = shift if @_;
5297 0 0       0  
5298 0         0 if (exists $INC{$_}) {
5299             return 1 if $INC{$_};
5300             croak "Compilation failed in require: $_";
5301             }
5302              
5303             # jcode.pl
5304             # ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
5305              
5306             # jacode.pl
5307 0 0       0 # http://search.cpan.org/dist/jacode/
5308 0         0  
5309             if (/ \b (?: jcode\.pl | jacode(?>[0-9]*)\.pl ) \z /oxms) {
5310             return CORE::require($_);
5311 0         0 }
5312              
5313             my $realfilename;
5314             my $result;
5315 0         0 ITER_REQUIRE:
  0         0  
5316 0 0       0 {
5317 0         0 for my $prefix (@INC) {
5318             if ($^O eq 'MacOS') {
5319             $realfilename = "$prefix$_";
5320 0         0 }
5321             else {
5322             $realfilename = "$prefix/$_";
5323 0 0       0 }
5324 0         0  
5325             if (Ekps9566::f($realfilename)) {
5326 0         0 $INC{$_} = $realfilename;
5327              
5328 0 0       0 my $script = '';
5329 0         0  
5330 0         0 if (Ekps9566::e("$realfilename.e")) {
5331 0         0 my $e_mtime = (Ekps9566::stat("$realfilename.e"))[9];
5332 0 0 0     0 my $mtime = (Ekps9566::stat($realfilename))[9];
5333 0         0 my $module_mtime = (Ekps9566::stat(__FILE__))[9];
5334             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5335             Ekps9566::unlink "$realfilename.e";
5336             }
5337 0 0       0 }
5338 0         0  
5339 0 0       0 if (Ekps9566::e("$realfilename.e")) {
5340 0 0       0 my $fh = gensym();
    0          
5341 0         0 _open_r($fh, "$realfilename.e") or croak "Can't open file: $realfilename.e";
5342             if ($^O eq 'MacOS') {
5343             CORE::eval q{
5344             CORE::require Mac::Files;
5345             Mac::Files::FSpSetFLock("$realfilename.e");
5346             };
5347 0         0 }
5348 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5349 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5350             if ($@) {
5351             carp "Can't immediately read-lock the file: $realfilename.e";
5352             }
5353 0         0 }
5354             else {
5355 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5356 0         0 }
5357 0 0       0 local $/ = undef; # slurp mode
5358 0         0 $script = <$fh>;
5359             if ($^O eq 'MacOS') {
5360             CORE::eval q{
5361             CORE::require Mac::Files;
5362             Mac::Files::FSpRstFLock("$realfilename.e");
5363 0 0       0 };
5364             }
5365             close($fh) or croak "Can't close file: $realfilename: $!";
5366 0         0 }
5367 0 0       0 else {
5368 0 0       0 my $fh = gensym();
    0          
5369 0         0 _open_r($fh, $realfilename) or croak "Can't open file: $realfilename";
5370             if ($^O eq 'MacOS') {
5371             CORE::eval q{
5372             CORE::require Mac::Files;
5373             Mac::Files::FSpSetFLock($realfilename);
5374             };
5375 0         0 }
5376 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5377 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5378             if ($@) {
5379             carp "Can't immediately read-lock the file: $realfilename";
5380             }
5381 0         0 }
5382             else {
5383 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5384 0         0 }
5385 0 0       0 local $/ = undef; # slurp mode
5386 0         0 $script = <$fh>;
5387             if ($^O eq 'MacOS') {
5388             CORE::eval q{
5389             CORE::require Mac::Files;
5390             Mac::Files::FSpRstFLock($realfilename);
5391 0 0       0 };
5392             }
5393 0 0       0 close($fh) or croak "Can't close file: $realfilename: $!";
5394 0         0  
5395 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) KPS9566 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5396 0         0 CORE::require KPS9566;
5397 0 0       0 $script = KPS9566::escape_script($script);
5398 0 0       0 my $fh = gensym();
    0          
5399 0         0 open($fh, ">$realfilename.e") or croak "Can't write open file: $realfilename.e";
5400             if ($^O eq 'MacOS') {
5401             CORE::eval q{
5402             CORE::require Mac::Files;
5403             Mac::Files::FSpSetFLock("$realfilename.e");
5404             };
5405 0         0 }
5406 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5407 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5408             if ($@) {
5409             carp "Can't immediately write-lock the file: $realfilename.e";
5410             }
5411 0         0 }
5412             else {
5413 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5414 0 0       0 }
5415 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5416 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5417 0         0 print {$fh} $script;
5418             if ($^O eq 'MacOS') {
5419             CORE::eval q{
5420             CORE::require Mac::Files;
5421             Mac::Files::FSpRstFLock("$realfilename.e");
5422 0 0       0 };
5423             }
5424             close($fh) or croak "Can't close file: $realfilename: $!";
5425             }
5426             }
5427 387     387   4828  
  387         4805  
  387         455535  
  0         0  
5428 0         0 {
5429             no strict;
5430 0         0 $result = scalar CORE::eval $script;
5431             }
5432             last ITER_REQUIRE;
5433 0         0 }
5434             }
5435             croak "Can't find $_ in \@INC";
5436 0 0       0 }
    0          
5437 0         0  
5438 0         0 if ($@) {
5439             $INC{$_} = undef;
5440             croak $@;
5441 0         0 }
5442 0         0 elsif (not $result) {
5443             delete $INC{$_};
5444             croak "$_ did not return true value";
5445 0         0 }
5446             else {
5447             return $result;
5448             }
5449             }
5450              
5451             #
5452             # KPS9566 telldir avoid warning
5453             #
5454 0     764 0 0 sub Ekps9566::telldir(*) {
5455              
5456 764         2234 local $^W = 0;
5457              
5458             return CORE::telldir $_[0];
5459             }
5460              
5461             #
5462             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
5463 764 0   0 0 44254 #
5464 0 0 0     0 sub Ekps9566::PREMATCH {
5465 0         0 if (defined($&)) {
5466             if (defined($1) and (CORE::substr($&,-CORE::length($1),CORE::length($1)) eq $1)) {
5467             return CORE::substr($&,0,CORE::length($&)-CORE::length($1));
5468 0         0 }
5469             else {
5470             croak 'Use of "$`", $PREMATCH, and ${^PREMATCH} need to /( capture all )/ in regexp';
5471             }
5472 0         0 }
5473             else {
5474 0         0 return '';
5475             }
5476             return $`;
5477             }
5478              
5479             #
5480             # ${^MATCH}, $MATCH, $& the string that matched
5481 0 0   0 0 0 #
5482 0 0       0 sub Ekps9566::MATCH {
5483 0         0 if (defined($&)) {
5484             if (defined($1)) {
5485             return $1;
5486 0         0 }
5487             else {
5488             croak 'Use of "$&", $MATCH, and ${^MATCH} need to /( capture all )/ in regexp';
5489             }
5490 0         0 }
5491             else {
5492 0         0 return '';
5493             }
5494             return $&;
5495             }
5496              
5497             #
5498             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
5499 0     0 0 0 #
5500             sub Ekps9566::POSTMATCH {
5501             return $';
5502             }
5503              
5504             #
5505             # KPS9566 character to order (with parameter)
5506             #
5507 0 0   0 1 0 sub KPS9566::ord(;$) {
5508              
5509 0 0       0 local $_ = shift if @_;
5510 0         0  
5511 0         0 if (/\A ($q_char) /oxms) {
5512 0         0 my @ord = unpack 'C*', $1;
5513 0         0 my $ord = 0;
5514             while (my $o = shift @ord) {
5515 0         0 $ord = $ord * 0x100 + $o;
5516             }
5517             return $ord;
5518 0         0 }
5519             else {
5520             return CORE::ord $_;
5521             }
5522             }
5523              
5524             #
5525             # KPS9566 character to order (without parameter)
5526             #
5527 0 0   0 0 0 sub KPS9566::ord_() {
5528 0         0  
5529 0         0 if (/\A ($q_char) /oxms) {
5530 0         0 my @ord = unpack 'C*', $1;
5531 0         0 my $ord = 0;
5532             while (my $o = shift @ord) {
5533 0         0 $ord = $ord * 0x100 + $o;
5534             }
5535             return $ord;
5536 0         0 }
5537             else {
5538             return CORE::ord $_;
5539             }
5540             }
5541              
5542             #
5543             # KPS9566 reverse
5544             #
5545 0 0   0 0 0 sub KPS9566::reverse(@) {
5546 0         0  
5547             if (wantarray) {
5548             return CORE::reverse @_;
5549             }
5550             else {
5551              
5552             # One of us once cornered Larry in an elevator and asked him what
5553             # problem he was solving with this, but he looked as far off into
5554             # the distance as he could in an elevator and said, "It seemed like
5555 0         0 # a good idea at the time."
5556              
5557             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
5558             }
5559             }
5560              
5561             #
5562             # KPS9566 getc (with parameter, without parameter)
5563             #
5564 0     0 0 0 sub KPS9566::getc(;*@) {
5565 0 0       0  
5566 0 0 0     0 my($package) = caller;
5567             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
5568 0         0 croak 'Too many arguments for KPS9566::getc' if @_ and not wantarray;
  0         0  
5569 0         0  
5570 0         0 my @length = sort { $a <=> $b } keys %range_tr;
5571 0         0 my $getc = '';
5572 0 0       0 for my $length ($length[0] .. $length[-1]) {
5573 0 0       0 $getc .= CORE::getc($fh);
5574 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
5575             if ($getc =~ /\A ${Ekps9566::dot_s} \z/oxms) {
5576             return wantarray ? ($getc,@_) : $getc;
5577             }
5578 0 0       0 }
5579             }
5580             return wantarray ? ($getc,@_) : $getc;
5581             }
5582              
5583             #
5584             # KPS9566 length by character
5585             #
5586 0 0   0 1 0 sub KPS9566::length(;$) {
5587              
5588 0         0 local $_ = shift if @_;
5589 0         0  
5590             local @_ = /\G ($q_char) /oxmsg;
5591             return scalar @_;
5592             }
5593              
5594             #
5595             # KPS9566 substr by character
5596             #
5597             BEGIN {
5598              
5599             # P.232 The lvalue Attribute
5600             # in Chapter 6: Subroutines
5601             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5602              
5603             # P.336 The lvalue Attribute
5604             # in Chapter 7: Subroutines
5605             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5606              
5607             # P.144 8.4 Lvalue subroutines
5608             # in Chapter 8: perlsub: Perl subroutines
5609 387 50 0 387 1 278198 # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
5610              
5611             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
5612             # vv----------------------*******
5613             sub KPS9566::substr($$;$$) %s {
5614              
5615             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5616              
5617             # If the substring is beyond either end of the string, substr() returns the undefined
5618             # value and produces a warning. When used as an lvalue, specifying a substring that
5619             # is entirely outside the string raises an exception.
5620             # http://perldoc.perl.org/functions/substr.html
5621              
5622             # A return with no argument returns the scalar value undef in scalar context,
5623             # an empty list () in list context, and (naturally) nothing at all in void
5624             # context.
5625              
5626             my $offset = $_[1];
5627             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
5628             return;
5629             }
5630              
5631             # substr($string,$offset,$length,$replacement)
5632             if (@_ == 4) {
5633             my(undef,undef,$length,$replacement) = @_;
5634             my $substr = join '', splice(@char, $offset, $length, $replacement);
5635             $_[0] = join '', @char;
5636              
5637             # return $substr; this doesn't work, don't say "return"
5638             $substr;
5639             }
5640              
5641             # substr($string,$offset,$length)
5642             elsif (@_ == 3) {
5643             my(undef,undef,$length) = @_;
5644             my $octet_offset = 0;
5645             my $octet_length = 0;
5646             if ($offset == 0) {
5647             $octet_offset = 0;
5648             }
5649             elsif ($offset > 0) {
5650             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5651             }
5652             else {
5653             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5654             }
5655             if ($length == 0) {
5656             $octet_length = 0;
5657             }
5658             elsif ($length > 0) {
5659             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
5660             }
5661             else {
5662             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
5663             }
5664             CORE::substr($_[0], $octet_offset, $octet_length);
5665             }
5666              
5667             # substr($string,$offset)
5668             else {
5669             my $octet_offset = 0;
5670             if ($offset == 0) {
5671             $octet_offset = 0;
5672             }
5673             elsif ($offset > 0) {
5674             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5675             }
5676             else {
5677             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5678             }
5679             CORE::substr($_[0], $octet_offset);
5680             }
5681             }
5682             END
5683             }
5684              
5685             #
5686             # KPS9566 index by character
5687             #
5688 0     0 1 0 sub KPS9566::index($$;$) {
5689 0 0       0  
5690 0         0 my $index;
5691             if (@_ == 3) {
5692             $index = Ekps9566::index($_[0], $_[1], CORE::length(KPS9566::substr($_[0], 0, $_[2])));
5693 0         0 }
5694             else {
5695             $index = Ekps9566::index($_[0], $_[1]);
5696 0 0       0 }
5697 0         0  
5698             if ($index == -1) {
5699             return -1;
5700 0         0 }
5701             else {
5702             return KPS9566::length(CORE::substr $_[0], 0, $index);
5703             }
5704             }
5705              
5706             #
5707             # KPS9566 rindex by character
5708             #
5709 0     0 1 0 sub KPS9566::rindex($$;$) {
5710 0 0       0  
5711 0         0 my $rindex;
5712             if (@_ == 3) {
5713             $rindex = Ekps9566::rindex($_[0], $_[1], CORE::length(KPS9566::substr($_[0], 0, $_[2])));
5714 0         0 }
5715             else {
5716             $rindex = Ekps9566::rindex($_[0], $_[1]);
5717 0 0       0 }
5718 0         0  
5719             if ($rindex == -1) {
5720             return -1;
5721 0         0 }
5722             else {
5723             return KPS9566::length(CORE::substr $_[0], 0, $rindex);
5724             }
5725             }
5726              
5727 387     387   4893 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  387         2394  
  387         41984  
5728             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
5729             use vars qw($slash); $slash = 'm//';
5730              
5731             # ord() to ord() or KPS9566::ord()
5732             my $function_ord = 'ord';
5733              
5734             # ord to ord or KPS9566::ord_
5735             my $function_ord_ = 'ord';
5736              
5737             # reverse to reverse or KPS9566::reverse
5738             my $function_reverse = 'reverse';
5739              
5740             # getc to getc or KPS9566::getc
5741             my $function_getc = 'getc';
5742              
5743             # P.1023 Appendix W.9 Multibyte Anchoring
5744             # of ISBN 1-56592-224-7 CJKV Information Processing
5745              
5746             my $anchor = '';
5747 387     387   5699 $anchor = q{${Ekps9566::anchor}};
  387     0   2503  
  387         24455383  
5748              
5749             use vars qw($nest);
5750              
5751             # regexp of nested parens in qqXX
5752              
5753             # P.340 Matching Nested Constructs with Embedded Code
5754             # in Chapter 7: Perl
5755             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5756              
5757             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
5758             [^\x81-\xFE\\()] |
5759             \( (?{$nest++}) |
5760             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5761             [\x81-\xFE][\x00-\xFF] |
5762             \\ [^\x81-\xFEc] |
5763             \\c[\x40-\x5F] |
5764             \\ [\x81-\xFE][\x00-\xFF] |
5765             [\x00-\xFF]
5766             }xms;
5767              
5768             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
5769             [^\x81-\xFE\\{}] |
5770             \{ (?{$nest++}) |
5771             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5772             [\x81-\xFE][\x00-\xFF] |
5773             \\ [^\x81-\xFEc] |
5774             \\c[\x40-\x5F] |
5775             \\ [\x81-\xFE][\x00-\xFF] |
5776             [\x00-\xFF]
5777             }xms;
5778              
5779             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
5780             [^\x81-\xFE\\\[\]] |
5781             \[ (?{$nest++}) |
5782             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5783             [\x81-\xFE][\x00-\xFF] |
5784             \\ [^\x81-\xFEc] |
5785             \\c[\x40-\x5F] |
5786             \\ [\x81-\xFE][\x00-\xFF] |
5787             [\x00-\xFF]
5788             }xms;
5789              
5790             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
5791             [^\x81-\xFE\\<>] |
5792             \< (?{$nest++}) |
5793             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5794             [\x81-\xFE][\x00-\xFF] |
5795             \\ [^\x81-\xFEc] |
5796             \\c[\x40-\x5F] |
5797             \\ [\x81-\xFE][\x00-\xFF] |
5798             [\x00-\xFF]
5799             }xms;
5800              
5801             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
5802             (?: ::)? (?:
5803             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5804             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5805             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5806             ))
5807             }xms;
5808              
5809             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
5810             (?: ::)? (?:
5811             (?>[0-9]+) |
5812             [^\x81-\xFEa-zA-Z_0-9\[\]] |
5813             ^[A-Z] |
5814             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5815             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5816             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5817             ))
5818             }xms;
5819              
5820             my $qq_substr = qr{(?> Char::substr | KPS9566::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
5821             }xms;
5822              
5823             # regexp of nested parens in qXX
5824             my $q_paren = qr{(?{local $nest=0}) (?>(?:
5825             [^\x81-\xFE()] |
5826             [\x81-\xFE][\x00-\xFF] |
5827             \( (?{$nest++}) |
5828             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5829             [\x00-\xFF]
5830             }xms;
5831              
5832             my $q_brace = qr{(?{local $nest=0}) (?>(?:
5833             [^\x81-\xFE\{\}] |
5834             [\x81-\xFE][\x00-\xFF] |
5835             \{ (?{$nest++}) |
5836             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5837             [\x00-\xFF]
5838             }xms;
5839              
5840             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
5841             [^\x81-\xFE\[\]] |
5842             [\x81-\xFE][\x00-\xFF] |
5843             \[ (?{$nest++}) |
5844             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5845             [\x00-\xFF]
5846             }xms;
5847              
5848             my $q_angle = qr{(?{local $nest=0}) (?>(?:
5849             [^\x81-\xFE<>] |
5850             [\x81-\xFE][\x00-\xFF] |
5851             \< (?{$nest++}) |
5852             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5853             [\x00-\xFF]
5854             }xms;
5855              
5856             my $matched = '';
5857             my $s_matched = '';
5858             $matched = q{$Ekps9566::matched};
5859             $s_matched = q{ Ekps9566::s_matched();};
5860              
5861             my $tr_variable = ''; # variable of tr///
5862             my $sub_variable = ''; # variable of s///
5863             my $bind_operator = ''; # =~ or !~
5864              
5865             my @heredoc = (); # here document
5866             my @heredoc_delimiter = ();
5867             my $here_script = ''; # here script
5868              
5869             #
5870             # escape KPS9566 script
5871 0 50   382 0 0 #
5872             sub KPS9566::escape(;$) {
5873             local($_) = $_[0] if @_;
5874              
5875             # P.359 The Study Function
5876             # in Chapter 7: Perl
5877 382         1245 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5878              
5879             study $_; # Yes, I studied study yesterday.
5880              
5881             # while all script
5882              
5883             # 6.14. Matching from Where the Last Pattern Left Off
5884             # in Chapter 6. Pattern Matching
5885             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
5886             # (and so on)
5887              
5888             # one member of Tag-team
5889             #
5890             # P.128 Start of match (or end of previous match): \G
5891             # P.130 Advanced Use of \G with Perl
5892             # in Chapter 3: Overview of Regular Expression Features and Flavors
5893             # P.255 Use leading anchors
5894             # P.256 Expose ^ and \G at the front expressions
5895             # in Chapter 6: Crafting an Efficient Expression
5896             # P.315 "Tag-team" matching with /gc
5897             # in Chapter 7: Perl
5898 382         1096 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5899 382         769  
5900 382         1517 my $e_script = '';
5901             while (not /\G \z/oxgc) { # member
5902             $e_script .= KPS9566::escape_token();
5903 186144         338409 }
5904              
5905             return $e_script;
5906             }
5907              
5908             #
5909             # escape KPS9566 token of script
5910             #
5911             sub KPS9566::escape_token {
5912              
5913 382     186144 0 5988 # \n output here document
5914              
5915             my $ignore_modules = join('|', qw(
5916             utf8
5917             bytes
5918             charnames
5919             I18N::Japanese
5920             I18N::Collate
5921             I18N::JExt
5922             File::DosGlob
5923             Wild
5924             Wildcard
5925             Japanese
5926             ));
5927              
5928             # another member of Tag-team
5929             #
5930             # P.315 "Tag-team" matching with /gc
5931             # in Chapter 7: Perl
5932 186144 100 100     242500 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
5933 186144         15554465  
5934 31248 100       45267 if (/\G ( \n ) /oxgc) { # another member (and so on)
5935 31248         57563 my $heredoc = '';
5936             if (scalar(@heredoc_delimiter) >= 1) {
5937 197         277 $slash = 'm//';
5938 197         604  
5939             $heredoc = join '', @heredoc;
5940             @heredoc = ();
5941 197         355  
5942 197         380 # skip here document
5943             for my $heredoc_delimiter (@heredoc_delimiter) {
5944 205         1298 /\G .*? \n $heredoc_delimiter \n/xmsgc;
5945             }
5946 197         353 @heredoc_delimiter = ();
5947              
5948 197         291 $here_script = '';
5949             }
5950             return "\n" . $heredoc;
5951             }
5952 31248         95345  
5953             # ignore space, comment
5954             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
5955              
5956             # if (, elsif (, unless (, while (, until (, given (, and when (
5957              
5958             # given, when
5959              
5960             # P.225 The given Statement
5961             # in Chapter 15: Smart Matching and given-when
5962             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5963              
5964             # P.133 The given Statement
5965             # in Chapter 4: Statements and Declarations
5966             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5967 42461         165858  
5968 3755         6428 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
5969             $slash = 'm//';
5970             return $1;
5971             }
5972              
5973             # scalar variable ($scalar = ...) =~ tr///;
5974             # scalar variable ($scalar = ...) =~ s///;
5975              
5976             # state
5977              
5978             # P.68 Persistent, Private Variables
5979             # in Chapter 4: Subroutines
5980             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5981              
5982             # P.160 Persistent Lexically Scoped Variables: state
5983             # in Chapter 4: Statements and Declarations
5984             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5985              
5986             # (and so on)
5987 3755         11935  
5988             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
5989 170 50       476 my $e_string = e_string($1);
    50          
5990 170         6975  
5991 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
5992 0         0 $tr_variable = $e_string . e_string($1);
5993 0         0 $bind_operator = $2;
5994             $slash = 'm//';
5995             return '';
5996 0         0 }
5997 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
5998 0         0 $sub_variable = $e_string . e_string($1);
5999 0         0 $bind_operator = $2;
6000             $slash = 'm//';
6001             return '';
6002 0         0 }
6003 170         375 else {
6004             $slash = 'div';
6005             return $e_string;
6006             }
6007             }
6008              
6009 170         777 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ekps9566::PREMATCH()
6010 4         10 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
6011             $slash = 'div';
6012             return q{Ekps9566::PREMATCH()};
6013             }
6014              
6015 4         16 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ekps9566::MATCH()
6016 28         59 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
6017             $slash = 'div';
6018             return q{Ekps9566::MATCH()};
6019             }
6020              
6021 28         83 # $', ${'} --> $', ${'}
6022 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
6023             $slash = 'div';
6024             return $1;
6025             }
6026              
6027 1         3 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ekps9566::POSTMATCH()
6028 3         7 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
6029             $slash = 'div';
6030             return q{Ekps9566::POSTMATCH()};
6031             }
6032              
6033             # scalar variable $scalar =~ tr///;
6034             # scalar variable $scalar =~ s///;
6035             # substr() =~ tr///;
6036 3         11 # substr() =~ s///;
6037             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
6038 2865 100       8000 my $scalar = e_string($1);
    100          
6039 2865         12094  
6040 9         15 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6041 9         16 $tr_variable = $scalar;
6042 9         14 $bind_operator = $1;
6043             $slash = 'm//';
6044             return '';
6045 9         25 }
6046 253         771 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6047 253         525 $sub_variable = $scalar;
6048 253         357 $bind_operator = $1;
6049             $slash = 'm//';
6050             return '';
6051 253         752 }
6052 2603         4066 else {
6053             $slash = 'div';
6054             return $scalar;
6055             }
6056             }
6057              
6058 2603         7208 # end of statement
6059             elsif (/\G ( [,;] ) /oxgc) {
6060             $slash = 'm//';
6061 12155         20015  
6062             # clear tr/// variable
6063             $tr_variable = '';
6064 12155         16844  
6065             # clear s/// variable
6066 12155         15667 $sub_variable = '';
6067              
6068 12155         14380 $bind_operator = '';
6069              
6070             return $1;
6071             }
6072              
6073 12155         43521 # bareword
6074             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
6075             return $1;
6076             }
6077              
6078 0         0 # $0 --> $0
6079 2         6 elsif (/\G ( \$ 0 ) /oxmsgc) {
6080             $slash = 'div';
6081             return $1;
6082 2         9 }
6083 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
6084             $slash = 'div';
6085             return $1;
6086             }
6087              
6088 0         0 # $$ --> $$
6089 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
6090             $slash = 'div';
6091             return $1;
6092             }
6093              
6094             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6095 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
6096 219         356 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
6097             $slash = 'div';
6098             return e_capture($1);
6099 219         634 }
6100 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
6101             $slash = 'div';
6102             return e_capture($1);
6103             }
6104              
6105 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6106 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
6107             $slash = 'div';
6108             return e_capture($1.'->'.$2);
6109             }
6110              
6111 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6112 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
6113             $slash = 'div';
6114             return e_capture($1.'->'.$2);
6115             }
6116              
6117 0         0 # $$foo
6118 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
6119             $slash = 'div';
6120             return e_capture($1);
6121             }
6122              
6123 0         0 # ${ foo }
6124 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
6125             $slash = 'div';
6126             return '${' . $1 . '}';
6127             }
6128              
6129 0         0 # ${ ... }
6130 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
6131             $slash = 'div';
6132             return e_capture($1);
6133             }
6134              
6135             # variable or function
6136 0         0 # $ @ % & * $ #
6137 605         976 elsif (/\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
6138             $slash = 'div';
6139             return $1;
6140             }
6141             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
6142 605         1948 # $ @ # \ ' " / ? ( ) [ ] < >
6143 103         210 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
6144             $slash = 'div';
6145             return $1;
6146             }
6147              
6148 103         401 # while ()
6149             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
6150             return $1;
6151             }
6152              
6153             # while () --- glob
6154              
6155             # avoid "Error: Runtime exception" of perl version 5.005_03
6156 0         0  
6157             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][\x00-\xFF])+?) > (?>\s*) \) \b /oxgc) {
6158             return 'while ($_ = Ekps9566::glob("' . $1 . '"))';
6159             }
6160              
6161 0         0 # while (glob)
6162             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
6163             return 'while ($_ = Ekps9566::glob_)';
6164             }
6165              
6166 0         0 # while (glob(WILDCARD))
6167             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
6168             return 'while ($_ = Ekps9566::glob';
6169             }
6170 0         0  
  478         1509  
6171             # doit if, doit unless, doit while, doit until, doit for, doit when
6172             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
6173 478         1929  
  19         36  
6174 19         81 # subroutines of package Ekps9566
  0         0  
6175 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         20  
6176 13         32 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
6177 0         0 elsif (/\G \b KPS9566::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         194  
6178 114         406 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         5  
6179 2         7 elsif (/\G \b KPS9566::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval KPS9566::escape'; }
  2         4  
6180 2         7 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         5  
6181 2         5 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::chop'; }
  0         0  
6182 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         4  
6183 2         6 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  2         6  
6184 2         8 elsif (/\G \b KPS9566::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'KPS9566::index'; }
  2         5  
6185 2         5 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::index'; }
  0         0  
6186 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         4  
6187 2         6 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  2         3  
6188 2         7 elsif (/\G \b KPS9566::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'KPS9566::rindex'; }
  1         2  
6189 1         4 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::rindex'; }
  0         0  
6190 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ekps9566::lc'; }
  0         0  
6191 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ekps9566::lcfirst'; }
  0         0  
6192 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ekps9566::uc'; }
  3         7  
6193             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ekps9566::ucfirst'; }
6194             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ekps9566::fc'; }
6195              
6196             # stacked file test operators
6197              
6198             # P.179 File Test Operators
6199             # in Chapter 12: File Tests
6200             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6201              
6202             # P.106 Named Unary and File Test Operators
6203             # in Chapter 3: Unary and Binary Operators
6204             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6205              
6206             # (and so on)
6207 3         11  
  0         0  
6208 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6209 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6210 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6211 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6212 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6213 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6214             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6215             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6216 0         0  
  4         9  
6217 4         18 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6218 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6219 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6220 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6221 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6222 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6223             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6224             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6225 0         0  
  0         0  
6226 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6227 0         0 { $slash = 'm//'; return "Ekps9566::filetest(qw($1),$2)"; }
  0         0  
6228 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1),$2)"; }
  0         0  
6229             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest qw($1),"; }
6230 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest(qw($1),$2)"; }
  0         0  
6231 0         0  
  0         0  
6232 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6233 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6234 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6235 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6236 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6237             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
6238 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  102         198  
6239 102         312  
  0         0  
6240 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6241 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6242 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6243 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6244 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6245             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6246             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6247 0         0  
  6         15  
6248 6         29 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6249 0         0 { $slash = 'm//'; return "Ekps9566::$1($2)"; }
  0         0  
6250 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Ekps9566::$1($2)"; }
  50         97  
6251 50         236 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return "Ekps9566::$1"; }
  2         6  
6252 2         8 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Ekps9566::$1(::"."$2)"; }
  1         3  
6253 1         5 elsif (/\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-t $2"; }
  3         8  
6254             elsif (/\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ekps9566::lstat'; }
6255             elsif (/\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ekps9566::stat'; }
6256 3         12  
  0         0  
6257 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
6258 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
6259 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6260 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6261 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6262 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6263             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
6264 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6265 0         0  
  0         0  
6266 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
6267 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6268 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6269 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6270 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6271             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6272             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6273 0         0  
  0         0  
6274 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6275 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
6276 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
6277             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
6278 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         4  
6279 2         8  
  2         4  
6280 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         81  
6281 36         126 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
6282 2         7 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ekps9566::chr'; }
  2         5  
6283 2         10 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  8         28  
6284 8         36 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
6285 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ekps9566::glob'; }
  0         0  
6286 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::lc_'; }
  0         0  
6287 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::lcfirst_'; }
  0         0  
6288 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::uc_'; }
  0         0  
6289 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::ucfirst_'; }
  0         0  
6290 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::fc_'; }
  0         0  
6291             elsif (/\G \b lstat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::lstat_'; }
6292 0         0 elsif (/\G \b stat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::stat_'; }
  0         0  
6293             elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
6294 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Ekps9566::filetest_(qw($1))"; }
  0         0  
6295             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC])
6296 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Ekps9566::${1}_"; }
  0         0  
6297              
6298 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
6299 0         0  
  0         0  
6300 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
6301 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
6302 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::chr_'; }
  2         7  
6303 2         9 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
6304 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  4         9  
6305 4         13 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::glob_'; }
  8         27  
6306 8         38 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  2         9  
6307 2         13 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0         0  
6308 0         0 elsif (/\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Ekps9566::opendir$1*"; }
  85         245  
6309             elsif (/\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Ekps9566::opendir$1*"; }
6310             elsif (/\G \b unlink \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ekps9566::unlink'; }
6311              
6312 85         369 # chdir
6313             elsif (/\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
6314 3         7 $slash = 'm//';
6315              
6316 3         6 my $e = 'Ekps9566::chdir';
6317 3         23  
6318             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6319             $e .= $1;
6320             }
6321 3 50       16  
  3 100       218  
    50          
    50          
    50          
    0          
6322             # end of chdir
6323             if (/\G (?= [,;\)\}\]] ) /oxgc) { return $e; }
6324 0         0  
6325             # chdir scalar value
6326             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return $e . e_string($1); }
6327              
6328 1 0       4 # chdir qq//
  0         0  
6329             elsif (/\G \b (qq) \b /oxgc) {
6330 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq# # --> qr # #
6331 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6332 0         0 while (not /\G \z/oxgc) {
6333 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6334 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq ( ) --> qr ( )
6335 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq { } --> qr { }
6336 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq [ ] --> qr [ ]
6337 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq < > --> qr < >
6338             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq','{','}',$2); } # qq | | --> qr { }
6339 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq * * --> qr * *
6340             }
6341             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6342             }
6343             }
6344              
6345 0 0       0 # chdir q//
  0         0  
6346             elsif (/\G \b (q) \b /oxgc) {
6347 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q# # --> qr # #
6348 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6349 0         0 while (not /\G \z/oxgc) {
6350 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6351 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q ( ) --> qr ( )
6352 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q { } --> qr { }
6353 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q [ ] --> qr [ ]
6354 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q < > --> qr < >
6355             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q','{','}',$2); } # q | | --> qr { }
6356 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q * * --> qr * *
6357             }
6358             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6359             }
6360             }
6361              
6362 0         0 # chdir ''
6363 2         6 elsif (/\G (\') /oxgc) {
6364 2 50       7 my $q_string = '';
  13 50       59  
    100          
    50          
6365 0         0 while (not /\G \z/oxgc) {
6366 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6367 2         8 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
6368             elsif (/\G \' /oxgc) { return $e . e_chdir_q('',"'","'",$q_string); }
6369 11         23 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6370             }
6371             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6372             }
6373              
6374 0         0 # chdir ""
6375 0         0 elsif (/\G (\") /oxgc) {
6376 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6377 0         0 while (not /\G \z/oxgc) {
6378 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6379 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
6380             elsif (/\G \" /oxgc) { return $e . e_chdir('','"','"',$qq_string); }
6381 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6382             }
6383             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6384             }
6385             }
6386              
6387 0         0 # split
6388             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
6389 404         936 $slash = 'm//';
6390 404         652  
6391 404         1546 my $e = '';
6392             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6393             $e .= $1;
6394             }
6395 401 100       1544  
  404 100       19311  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
6396             # end of split
6397             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Ekps9566::split' . $e; }
6398 3         15  
6399             # split scalar value
6400             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Ekps9566::split' . $e . e_string($1); }
6401 1         6  
6402 0         0 # split literal space
6403 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Ekps9566::split' . $e . qq {qq$1 $2}; }
6404 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ekps9566::split' . $e . qq{$1qq$2 $3}; }
6405 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ekps9566::split' . $e . qq{$1qq$2 $3}; }
6406 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ekps9566::split' . $e . qq{$1qq$2 $3}; }
6407 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ekps9566::split' . $e . qq{$1qq$2 $3}; }
6408 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ekps9566::split' . $e . qq{$1qq$2 $3}; }
6409 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Ekps9566::split' . $e . qq {q$1 $2}; }
6410 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ekps9566::split' . $e . qq {$1q$2 $3}; }
6411 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ekps9566::split' . $e . qq {$1q$2 $3}; }
6412 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ekps9566::split' . $e . qq {$1q$2 $3}; }
6413 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ekps9566::split' . $e . qq {$1q$2 $3}; }
6414 13         69 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ekps9566::split' . $e . qq {$1q$2 $3}; }
6415             elsif (/\G ' [ ] ' /oxgc) { return 'Ekps9566::split' . $e . qq {' '}; }
6416             elsif (/\G " [ ] " /oxgc) { return 'Ekps9566::split' . $e . qq {" "}; }
6417              
6418 2 0       10 # split qq//
  0         0  
6419             elsif (/\G \b (qq) \b /oxgc) {
6420 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
6421 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6422 0         0 while (not /\G \z/oxgc) {
6423 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6424 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
6425 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
6426 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
6427 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
6428             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
6429 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
6430             }
6431             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6432             }
6433             }
6434              
6435 0 50       0 # split qr//
  124         899  
6436             elsif (/\G \b (qr) \b /oxgc) {
6437 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
6438 124 50       389 else {
  124 50       7215  
    50          
    50          
    50          
    100          
    50          
    50          
6439 0         0 while (not /\G \z/oxgc) {
6440 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6441 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
6442 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
6443 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
6444 56         323 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
6445 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
6446             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
6447 68         367 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
6448             }
6449             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6450             }
6451             }
6452              
6453 0 0       0 # split q//
  0         0  
6454             elsif (/\G \b (q) \b /oxgc) {
6455 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
6456 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6457 0         0 while (not /\G \z/oxgc) {
6458 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6459 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
6460 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
6461 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
6462 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
6463             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
6464 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
6465             }
6466             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6467             }
6468             }
6469              
6470 0 50       0 # split m//
  136         975  
6471             elsif (/\G \b (m) \b /oxgc) {
6472 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
6473 136 50       387 else {
  136 50       6552  
    50          
    50          
    50          
    100          
    50          
    50          
6474 0         0 while (not /\G \z/oxgc) {
6475 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6476 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
6477 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
6478 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
6479 56         233 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
6480 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
6481             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
6482 80         568 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
6483             }
6484             die __FILE__, ": Search pattern not terminated\n";
6485             }
6486             }
6487              
6488 0         0 # split ''
6489 0         0 elsif (/\G (\') /oxgc) {
6490 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6491 0         0 while (not /\G \z/oxgc) {
6492 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6493 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
6494             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
6495 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6496             }
6497             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6498             }
6499              
6500 0         0 # split ""
6501 0         0 elsif (/\G (\") /oxgc) {
6502 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6503 0         0 while (not /\G \z/oxgc) {
6504 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6505 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
6506             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
6507 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6508             }
6509             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6510             }
6511              
6512 0         0 # split //
6513 125         272 elsif (/\G (\/) /oxgc) {
6514 125 50       382 my $regexp = '';
  558 50       2625  
    100          
    50          
6515 0         0 while (not /\G \z/oxgc) {
6516 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
6517 125         479 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
6518             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
6519 433         1016 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
6520             }
6521             die __FILE__, ": Search pattern not terminated\n";
6522             }
6523             }
6524              
6525             # tr/// or y///
6526              
6527             # about [cdsrbB]* (/B modifier)
6528             #
6529             # P.559 appendix C
6530             # of ISBN 4-89052-384-7 Programming perl
6531             # (Japanese title is: Perl puroguramingu)
6532 0         0  
6533             elsif (/\G \b ( tr | y ) \b /oxgc) {
6534             my $ope = $1;
6535 11 50       30  
6536 11         161 # $1 $2 $3 $4 $5 $6
6537 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
6538             my @tr = ($tr_variable,$2);
6539             return e_tr(@tr,'',$4,$6);
6540 0         0 }
6541 11         20 else {
6542 11 50       31 my $e = '';
  11 50       734  
    50          
    50          
    50          
    50          
6543             while (not /\G \z/oxgc) {
6544 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6545 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6546 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6547 0         0 while (not /\G \z/oxgc) {
6548 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6549 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
6550 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
6551 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
6552             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
6553 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
6554             }
6555             die __FILE__, ": Transliteration replacement not terminated\n";
6556 0         0 }
6557 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6558 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6559 0         0 while (not /\G \z/oxgc) {
6560 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6561 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
6562 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
6563 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
6564             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
6565 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
6566             }
6567             die __FILE__, ": Transliteration replacement not terminated\n";
6568 0         0 }
6569 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6570 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6571 0         0 while (not /\G \z/oxgc) {
6572 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6573 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
6574 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
6575 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
6576             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
6577 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
6578             }
6579             die __FILE__, ": Transliteration replacement not terminated\n";
6580 0         0 }
6581 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6582 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6583 0         0 while (not /\G \z/oxgc) {
6584 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6585 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
6586 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
6587 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
6588             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
6589 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
6590             }
6591             die __FILE__, ": Transliteration replacement not terminated\n";
6592             }
6593 0         0 # $1 $2 $3 $4 $5 $6
6594 11         42 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
6595             my @tr = ($tr_variable,$2);
6596             return e_tr(@tr,'',$4,$6);
6597 11         57 }
6598             }
6599             die __FILE__, ": Transliteration pattern not terminated\n";
6600             }
6601             }
6602              
6603 0         0 # qq//
6604             elsif (/\G \b (qq) \b /oxgc) {
6605             my $ope = $1;
6606 5897 100       17576  
6607 5897         12246 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
6608 40         50 if (/\G (\#) /oxgc) { # qq# #
6609 40 100       88 my $qq_string = '';
  1948 50       5232  
    100          
    50          
6610 80         144 while (not /\G \z/oxgc) {
6611 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6612 40         100 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
6613             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
6614 1828         3286 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6615             }
6616             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6617             }
6618 0         0  
6619 5857         8258 else {
6620 5857 50       16172 my $e = '';
  5857 50       27271  
    100          
    50          
    100          
    50          
6621             while (not /\G \z/oxgc) {
6622             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6623              
6624 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
6625 0         0 elsif (/\G (\() /oxgc) { # qq ( )
6626 0         0 my $qq_string = '';
6627 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6628 0         0 while (not /\G \z/oxgc) {
6629 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6630             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
6631 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6632 0         0 elsif (/\G (\)) /oxgc) {
6633             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
6634 0         0 else { $qq_string .= $1; }
6635             }
6636 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6637             }
6638             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6639             }
6640              
6641 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
6642 5775         8491 elsif (/\G (\{) /oxgc) { # qq { }
6643 5775         9646 my $qq_string = '';
6644 5775 100       13781 local $nest = 1;
  246111 50       807037  
    100          
    100          
    50          
6645 720         1405 while (not /\G \z/oxgc) {
6646 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1384         1976  
6647             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
6648 1384 100       2324 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  7159         16407  
6649 5775         14107 elsif (/\G (\}) /oxgc) {
6650             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
6651 1384         2754 else { $qq_string .= $1; }
6652             }
6653 236848         498012 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6654             }
6655             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6656             }
6657              
6658 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
6659 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
6660 0         0 my $qq_string = '';
6661 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6662 0         0 while (not /\G \z/oxgc) {
6663 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6664             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
6665 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6666 0         0 elsif (/\G (\]) /oxgc) {
6667             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
6668 0         0 else { $qq_string .= $1; }
6669             }
6670 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6671             }
6672             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6673             }
6674              
6675 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
6676 62         130 elsif (/\G (\<) /oxgc) { # qq < >
6677 62         109 my $qq_string = '';
6678 62 100       167 local $nest = 1;
  2040 50       8190  
    100          
    100          
    50          
6679 22         50 while (not /\G \z/oxgc) {
6680 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  2         3  
6681             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
6682 2 100       3 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  64         167  
6683 62         447 elsif (/\G (\>) /oxgc) {
6684             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
6685 2         6 else { $qq_string .= $1; }
6686             }
6687 1952         4936 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6688             }
6689             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6690             }
6691              
6692 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
6693 20         30 elsif (/\G (\S) /oxgc) { # qq * *
6694 20         24 my $delimiter = $1;
6695 20 50       60 my $qq_string = '';
  840 50       2346  
    100          
    50          
6696 0         0 while (not /\G \z/oxgc) {
6697 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6698 20         40 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
6699             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
6700 820         1523 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6701             }
6702             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6703 0         0 }
6704             }
6705             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6706             }
6707             }
6708              
6709 0         0 # qr//
6710 184 50       689 elsif (/\G \b (qr) \b /oxgc) {
6711 184         814 my $ope = $1;
6712             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
6713             return e_qr($ope,$1,$3,$2,$4);
6714 0         0 }
6715 184         303 else {
6716 184 50       451 my $e = '';
  184 50       6895  
    100          
    50          
    50          
    100          
    50          
    50          
6717 0         0 while (not /\G \z/oxgc) {
6718 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6719 1         6 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
6720 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
6721 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
6722 76         205 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
6723 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
6724             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
6725 107         384 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
6726             }
6727             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6728             }
6729             }
6730              
6731 0         0 # qw//
6732 34 50       118 elsif (/\G \b (qw) \b /oxgc) {
6733 34         112 my $ope = $1;
6734             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
6735             return e_qw($ope,$1,$3,$2);
6736 0         0 }
6737 34         71 else {
6738 34 50       128 my $e = '';
  34 50       227  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6739             while (not /\G \z/oxgc) {
6740 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6741 34         138  
6742             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6743 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6744 0         0  
6745             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6746 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6747 0         0  
6748             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6749 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6750 0         0  
6751             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6752 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6753 0         0  
6754             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6755 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6756             }
6757             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6758             }
6759             }
6760              
6761 0         0 # qx//
6762 3 50       9 elsif (/\G \b (qx) \b /oxgc) {
6763 3         70 my $ope = $1;
6764             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
6765             return e_qq($ope,$1,$3,$2);
6766 0         0 }
6767 3         7 else {
6768 3 50       11 my $e = '';
  3 50       374  
    100          
    50          
    50          
    50          
    50          
6769 0         0 while (not /\G \z/oxgc) {
6770 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6771 2         6 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
6772 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
6773 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
6774 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
6775             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
6776 1         6 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
6777             }
6778             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6779             }
6780             }
6781              
6782 0         0 # q//
6783             elsif (/\G \b (q) \b /oxgc) {
6784             my $ope = $1;
6785              
6786             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
6787              
6788             # avoid "Error: Runtime exception" of perl version 5.005_03
6789 604 50       1958 # (and so on)
6790 604         1876  
6791 0         0 if (/\G (\#) /oxgc) { # q# #
6792 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6793 0         0 while (not /\G \z/oxgc) {
6794 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6795 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
6796             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
6797 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6798             }
6799             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6800             }
6801 0         0  
6802 604         1182 else {
6803 604 50       2118 my $e = '';
  604 100       3862  
    100          
    50          
    100          
    50          
6804             while (not /\G \z/oxgc) {
6805             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6806              
6807 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
6808 1         2 elsif (/\G (\() /oxgc) { # q ( )
6809 1         2 my $q_string = '';
6810 1 50       3 local $nest = 1;
  7 50       48  
    50          
    50          
    100          
    50          
6811 0         0 while (not /\G \z/oxgc) {
6812 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6813 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
6814             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
6815 0 50       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  1         2  
6816 1         3 elsif (/\G (\)) /oxgc) {
6817             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
6818 0         0 else { $q_string .= $1; }
6819             }
6820 6         14 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6821             }
6822             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6823             }
6824              
6825 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
6826 597         1127 elsif (/\G (\{) /oxgc) { # q { }
6827 597         1120 my $q_string = '';
6828 597 50       1838 local $nest = 1;
  8237 50       42230  
    50          
    100          
    100          
    50          
6829 0         0 while (not /\G \z/oxgc) {
6830 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6831 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  114         185  
6832             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
6833 114 100       220 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  711         1705  
6834 597         2176 elsif (/\G (\}) /oxgc) {
6835             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
6836 114         232 else { $q_string .= $1; }
6837             }
6838 7412         16210 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6839             }
6840             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6841             }
6842              
6843 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
6844 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
6845 0         0 my $q_string = '';
6846 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
6847 0         0 while (not /\G \z/oxgc) {
6848 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6849 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
6850             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
6851 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
6852 0         0 elsif (/\G (\]) /oxgc) {
6853             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
6854 0         0 else { $q_string .= $1; }
6855             }
6856 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6857             }
6858             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6859             }
6860              
6861 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
6862 5         13 elsif (/\G (\<) /oxgc) { # q < >
6863 5         12 my $q_string = '';
6864 5 50       22 local $nest = 1;
  82 50       697  
    50          
    50          
    100          
    50          
6865 0         0 while (not /\G \z/oxgc) {
6866 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6867 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
6868             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
6869 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         16  
6870 5         19 elsif (/\G (\>) /oxgc) {
6871             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
6872 0         0 else { $q_string .= $1; }
6873             }
6874 77         162 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6875             }
6876             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6877             }
6878              
6879 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
6880 1         3 elsif (/\G (\S) /oxgc) { # q * *
6881 1         2 my $delimiter = $1;
6882 1 50       4 my $q_string = '';
  14 50       80  
    100          
    50          
6883 0         0 while (not /\G \z/oxgc) {
6884 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6885 1         4 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
6886             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
6887 13         27 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6888             }
6889             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6890 0         0 }
6891             }
6892             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6893             }
6894             }
6895              
6896 0         0 # m//
6897 491 50       1797 elsif (/\G \b (m) \b /oxgc) {
6898 491         3645 my $ope = $1;
6899             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
6900             return e_qr($ope,$1,$3,$2,$4);
6901 0         0 }
6902 491         856 else {
6903 491 50       1335 my $e = '';
  491 50       35326  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6904 0         0 while (not /\G \z/oxgc) {
6905 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6906 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
6907 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
6908 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
6909 92         282 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
6910 87         353 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
6911 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
6912             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
6913 312         1051 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
6914             }
6915             die __FILE__, ": Search pattern not terminated\n";
6916             }
6917             }
6918              
6919             # s///
6920              
6921             # about [cegimosxpradlunbB]* (/cg modifier)
6922             #
6923             # P.67 Pattern-Matching Operators
6924             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
6925 0         0  
6926             elsif (/\G \b (s) \b /oxgc) {
6927             my $ope = $1;
6928 290 100       1022  
6929 290         5157 # $1 $2 $3 $4 $5 $6
6930             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
6931             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
6932 1         7 }
6933 289         1064 else {
6934 289 50       872 my $e = '';
  289 50       29857  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6935             while (not /\G \z/oxgc) {
6936 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6937 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6938 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6939             while (not /\G \z/oxgc) {
6940 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6941 0         0 # $1 $2 $3 $4
6942 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6943 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6944 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6945 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6946 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6947 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6948 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6949             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6950 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6951             }
6952             die __FILE__, ": Substitution replacement not terminated\n";
6953 0         0 }
6954 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6955 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6956             while (not /\G \z/oxgc) {
6957 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6958 0         0 # $1 $2 $3 $4
6959 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6960 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6961 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6962 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6963 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6964 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6965 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6966             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6967 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6968             }
6969             die __FILE__, ": Substitution replacement not terminated\n";
6970 0         0 }
6971 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6972 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
6973             while (not /\G \z/oxgc) {
6974 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6975 0         0 # $1 $2 $3 $4
6976 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6977 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6978 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6979 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6980 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6981             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6982 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6983             }
6984             die __FILE__, ": Substitution replacement not terminated\n";
6985 0         0 }
6986 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6987 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6988             while (not /\G \z/oxgc) {
6989 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6990 0         0 # $1 $2 $3 $4
6991 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6992 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6993 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6994 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6995 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6996 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6997 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6998             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6999 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7000             }
7001             die __FILE__, ": Substitution replacement not terminated\n";
7002             }
7003 0         0 # $1 $2 $3 $4 $5 $6
7004             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
7005             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7006             }
7007 96         273 # $1 $2 $3 $4 $5 $6
7008             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7009             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
7010             }
7011 2         25 # $1 $2 $3 $4 $5 $6
7012             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7013             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7014             }
7015 0         0 # $1 $2 $3 $4 $5 $6
7016             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7017             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7018 191         881 }
7019             }
7020             die __FILE__, ": Substitution pattern not terminated\n";
7021             }
7022             }
7023 0         0  
7024 1         5 # do
7025 0         0 elsif (/\G \b do (?= (?>\s*) \{ ) /oxmsgc) { return 'do'; }
7026 0         0 elsif (/\G \b do (?= (?>\s+) (?: q | qq | qx ) \b) /oxmsgc) { return 'Ekps9566::do'; }
7027 0         0 elsif (/\G \b do (?= (?>\s+) (?>\w+)) /oxmsgc) { return 'do'; }
7028             elsif (/\G \b do (?= (?>\s*) \$ (?> \w+ (?: ::\w+)* ) \( ) /oxmsgc) { return 'do'; }
7029             elsif (/\G \b do \b /oxmsgc) { return 'Ekps9566::do'; }
7030 2         9  
7031 0         0 # require ignore module
7032 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
7033             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# require$1\n$2"; }
7034             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
7035 0         0  
7036 0         0 # require version number
7037 0         0 elsif (/\G \b require (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7038             elsif (/\G \b require (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7039             elsif (/\G \b require (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7040 0         0  
7041             # require bare package name
7042             elsif (/\G \b require (?>\s+) ((?>[A-Za-z_]\w* (?: :: [A-Za-z_]\w*)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7043 18         130  
7044 0         0 # require else
7045             elsif (/\G \b require (?>\s*) ; /oxmsgc) { return 'Ekps9566::require;'; }
7046             elsif (/\G \b require \b /oxmsgc) { return 'Ekps9566::require'; }
7047 1         5  
7048 70         633 # use strict; --> use strict; no strict qw(refs);
7049 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
7050             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
7051             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
7052              
7053 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
7054 3         47 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7055             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
7056             return "use $1; no strict qw(refs);";
7057 0         0 }
7058             else {
7059             return "use $1;";
7060             }
7061 3 0 0     20 }
      0        
7062 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7063             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
7064             return "use $1; no strict qw(refs);";
7065 0         0 }
7066             else {
7067             return "use $1;";
7068             }
7069             }
7070 0         0  
7071 2         16 # ignore use module
7072 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
7073             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# use$1\n$2"; }
7074             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
7075 0         0  
7076 0         0 # ignore no module
7077 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
7078             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# no$1\n$2"; }
7079             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
7080 0         0  
7081 0         0 # use without import
7082 0         0 elsif (/\G \b use (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7083 0         0 elsif (/\G \b use (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7084 0         0 elsif (/\G \b use (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7085 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7086 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7087 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7088 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7089 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7090             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7091             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7092 0         0  
7093             # use with import no parameter
7094             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_use_noparam($1); }
7095 0         0  
7096 0         0 # use with import parameters
7097 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7098 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\xFE']* \') (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7099 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\xFE"]* \") (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7100 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7101 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\{) (?:$q_char)*? \}) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7102 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\[) (?:$q_char)*? \]) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7103 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\<) [^\x81-\xFE>]* \>) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7104             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7105             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\S) (?:$q_char)*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7106 0         0  
7107 0         0 # no without unimport
7108 0         0 elsif (/\G \b no (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7109 0         0 elsif (/\G \b no (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7110 0         0 elsif (/\G \b no (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7111 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7112 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7113 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7114 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7115 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7116             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7117             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7118 0         0  
7119             # no with unimport no parameter
7120             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_no_noparam($1); }
7121 0         0  
7122 0         0 # no with unimport parameters
7123 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7124 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\xFE']* \') (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7125 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\xFE"]* \") (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7126 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7127 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\{) (?:$q_char)*? \}) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7128 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\[) (?:$q_char)*? \]) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7129 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\<) [^\x81-\xFE>]* \>) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7130             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7131             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\S) (?:$q_char)*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7132 0         0  
7133             # use else
7134             elsif (/\G \b use \b /oxmsgc) { return "use"; }
7135 0         0  
7136             # use else
7137             elsif (/\G \b no \b /oxmsgc) { return "no"; }
7138              
7139 2         9 # ''
7140 3173         8097 elsif (/\G (?
7141 3173 100       9204 my $q_string = '';
  15660 100       56887  
    100          
    50          
7142 8         21 while (not /\G \z/oxgc) {
7143 48         93 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
7144 3173         8446 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
7145             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
7146 12431         28515 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7147             }
7148             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7149             }
7150              
7151 0         0 # ""
7152 3362         26551 elsif (/\G (\") /oxgc) {
7153 3362 100       9539 my $qq_string = '';
  69440 100       249774  
    100          
    50          
7154 109         330 while (not /\G \z/oxgc) {
7155 14         28 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7156 3362         9164 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
7157             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
7158 65955         147881 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
7159             }
7160             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7161             }
7162              
7163 0         0 # ``
7164 37         113 elsif (/\G (\`) /oxgc) {
7165 37 50       158 my $qx_string = '';
  313 50       3029  
    100          
    50          
7166 0         0 while (not /\G \z/oxgc) {
7167 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
7168 37         156 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
7169             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
7170 276         697 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
7171             }
7172             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7173             }
7174              
7175 0         0 # // --- not divide operator (num / num), not defined-or
7176 1229         3333 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
7177 1229 100       4155 my $regexp = '';
  12510 50       46055  
    100          
    50          
7178 11         35 while (not /\G \z/oxgc) {
7179 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7180 1229         4006 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
7181             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
7182 11270         29607 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7183             }
7184             die __FILE__, ": Search pattern not terminated\n";
7185             }
7186              
7187 0         0 # ?? --- not conditional operator (condition ? then : else)
7188 92         230 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
7189 92 50       271 my $regexp = '';
  266 50       1286  
    100          
    50          
7190 0         0 while (not /\G \z/oxgc) {
7191 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7192 92         251 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
7193             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
7194 174         541 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7195             }
7196             die __FILE__, ": Search pattern not terminated\n";
7197             }
7198 0         0  
  0         0  
7199             # <<>> (a safer ARGV)
7200             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
7201 0         0  
  0         0  
7202             # << (bit shift) --- not here document
7203             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
7204              
7205 0         0 # <<~'HEREDOC'
7206 6         13 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
7207 6         16 $slash = 'm//';
7208             my $here_quote = $1;
7209             my $delimiter = $2;
7210 6 50       14  
7211 6         16 # get here document
7212 6         39 if ($here_script eq '') {
7213             $here_script = CORE::substr $_, pos $_;
7214 6 50       38 $here_script =~ s/.*?\n//oxm;
7215 6         78 }
7216 6         16 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7217 6         11 my $heredoc = $1;
7218 6         55 my $indent = $2;
7219 6         28 $heredoc =~ s{^$indent}{}msg; # no /ox
7220             push @heredoc, $heredoc . qq{\n$delimiter\n};
7221             push @heredoc_delimiter, qq{\\s*$delimiter};
7222 6         19 }
7223             else {
7224 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7225             }
7226             return qq{<<'$delimiter'};
7227             }
7228              
7229             # <<~\HEREDOC
7230              
7231             # P.66 2.6.6. "Here" Documents
7232             # in Chapter 2: Bits and Pieces
7233             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7234              
7235             # P.73 "Here" Documents
7236             # in Chapter 2: Bits and Pieces
7237             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7238 6         28  
7239 3         8 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
7240 3         7 $slash = 'm//';
7241             my $here_quote = $1;
7242             my $delimiter = $2;
7243 3 50       11  
7244 3         9 # get here document
7245 3         17 if ($here_script eq '') {
7246             $here_script = CORE::substr $_, pos $_;
7247 3 50       18 $here_script =~ s/.*?\n//oxm;
7248 3         39 }
7249 3         9 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7250 3         6 my $heredoc = $1;
7251 3         37 my $indent = $2;
7252 3         15 $heredoc =~ s{^$indent}{}msg; # no /ox
7253             push @heredoc, $heredoc . qq{\n$delimiter\n};
7254             push @heredoc_delimiter, qq{\\s*$delimiter};
7255 3         8 }
7256             else {
7257 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7258             }
7259             return qq{<<\\$delimiter};
7260             }
7261              
7262 3         13 # <<~"HEREDOC"
7263 6         15 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
7264 6         16 $slash = 'm//';
7265             my $here_quote = $1;
7266             my $delimiter = $2;
7267 6 50       18  
7268 6         19 # get here document
7269 6         27 if ($here_script eq '') {
7270             $here_script = CORE::substr $_, pos $_;
7271 6 50       36 $here_script =~ s/.*?\n//oxm;
7272 6         63 }
7273 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7274 6         8 my $heredoc = $1;
7275 6         52 my $indent = $2;
7276 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
7277             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7278             push @heredoc_delimiter, qq{\\s*$delimiter};
7279 6         14 }
7280             else {
7281 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7282             }
7283             return qq{<<"$delimiter"};
7284             }
7285              
7286 6         26 # <<~HEREDOC
7287 3         10 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
7288 3         7 $slash = 'm//';
7289             my $here_quote = $1;
7290             my $delimiter = $2;
7291 3 50       5  
7292 3         9 # get here document
7293 3         15 if ($here_script eq '') {
7294             $here_script = CORE::substr $_, pos $_;
7295 3 50       16 $here_script =~ s/.*?\n//oxm;
7296 3         39 }
7297 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7298 3         5 my $heredoc = $1;
7299 3         37 my $indent = $2;
7300 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
7301             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7302             push @heredoc_delimiter, qq{\\s*$delimiter};
7303 3         10 }
7304             else {
7305 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7306             }
7307             return qq{<<$delimiter};
7308             }
7309              
7310 3         14 # <<~`HEREDOC`
7311 6         15 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
7312 6         13 $slash = 'm//';
7313             my $here_quote = $1;
7314             my $delimiter = $2;
7315 6 50       10  
7316 6         14 # get here document
7317 6         22 if ($here_script eq '') {
7318             $here_script = CORE::substr $_, pos $_;
7319 6 50       41 $here_script =~ s/.*?\n//oxm;
7320 6         59 }
7321 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7322 6         9 my $heredoc = $1;
7323 6         56 my $indent = $2;
7324 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
7325             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7326             push @heredoc_delimiter, qq{\\s*$delimiter};
7327 6         14 }
7328             else {
7329 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7330             }
7331             return qq{<<`$delimiter`};
7332             }
7333              
7334 6         24 # <<'HEREDOC'
7335 86         203 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
7336 86         200 $slash = 'm//';
7337             my $here_quote = $1;
7338             my $delimiter = $2;
7339 86 100       155  
7340 86         205 # get here document
7341 83         526 if ($here_script eq '') {
7342             $here_script = CORE::substr $_, pos $_;
7343 83 50       523 $here_script =~ s/.*?\n//oxm;
7344 86         804 }
7345 86         314 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7346             push @heredoc, $1 . qq{\n$delimiter\n};
7347             push @heredoc_delimiter, $delimiter;
7348 86         135 }
7349             else {
7350 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7351             }
7352             return $here_quote;
7353             }
7354              
7355             # <<\HEREDOC
7356              
7357             # P.66 2.6.6. "Here" Documents
7358             # in Chapter 2: Bits and Pieces
7359             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7360              
7361             # P.73 "Here" Documents
7362             # in Chapter 2: Bits and Pieces
7363             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7364 86         347  
7365 2         7 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
7366 2         5 $slash = 'm//';
7367             my $here_quote = $1;
7368             my $delimiter = $2;
7369 2 100       3  
7370 2         5 # get here document
7371 1         6 if ($here_script eq '') {
7372             $here_script = CORE::substr $_, pos $_;
7373 1 50       15 $here_script =~ s/.*?\n//oxm;
7374 2         28 }
7375 2         8 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7376             push @heredoc, $1 . qq{\n$delimiter\n};
7377             push @heredoc_delimiter, $delimiter;
7378 2         3 }
7379             else {
7380 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7381             }
7382             return $here_quote;
7383             }
7384              
7385 2         8 # <<"HEREDOC"
7386 39         102 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
7387 39         101 $slash = 'm//';
7388             my $here_quote = $1;
7389             my $delimiter = $2;
7390 39 100       75  
7391 39         103 # get here document
7392 38         234 if ($here_script eq '') {
7393             $here_script = CORE::substr $_, pos $_;
7394 38 50       216 $here_script =~ s/.*?\n//oxm;
7395 39         476 }
7396 39         123 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7397             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7398             push @heredoc_delimiter, $delimiter;
7399 39         96 }
7400             else {
7401 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7402             }
7403             return $here_quote;
7404             }
7405              
7406 39         176 # <
7407 54         147 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
7408 54         119 $slash = 'm//';
7409             my $here_quote = $1;
7410             my $delimiter = $2;
7411 54 100       103  
7412 54         165 # get here document
7413 51         343 if ($here_script eq '') {
7414             $here_script = CORE::substr $_, pos $_;
7415 51 50       370 $here_script =~ s/.*?\n//oxm;
7416 54         725 }
7417 54         178 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7418             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7419             push @heredoc_delimiter, $delimiter;
7420 54         126 }
7421             else {
7422 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7423             }
7424             return $here_quote;
7425             }
7426              
7427 54         232 # <<`HEREDOC`
7428 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
7429 0         0 $slash = 'm//';
7430             my $here_quote = $1;
7431             my $delimiter = $2;
7432 0 0       0  
7433 0         0 # get here document
7434 0         0 if ($here_script eq '') {
7435             $here_script = CORE::substr $_, pos $_;
7436 0 0       0 $here_script =~ s/.*?\n//oxm;
7437 0         0 }
7438 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7439             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7440             push @heredoc_delimiter, $delimiter;
7441 0         0 }
7442             else {
7443 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7444             }
7445             return $here_quote;
7446             }
7447              
7448 0         0 # <<= <=> <= < operator
7449             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
7450             return $1;
7451             }
7452              
7453 13         74 #
7454             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
7455             return $1;
7456             }
7457              
7458             # --- glob
7459              
7460             # avoid "Error: Runtime exception" of perl version 5.005_03
7461 0         0  
7462             elsif (/\G < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][\x00-\xFF])+?) > /oxgc) {
7463             return 'Ekps9566::glob("' . $1 . '")';
7464             }
7465 0         0  
7466             # __DATA__
7467             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
7468 0         0  
7469             # __END__
7470             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
7471              
7472             # \cD Control-D
7473              
7474             # P.68 2.6.8. Other Literal Tokens
7475             # in Chapter 2: Bits and Pieces
7476             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7477              
7478             # P.76 Other Literal Tokens
7479             # in Chapter 2: Bits and Pieces
7480 382         4145 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7481              
7482             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
7483 0         0  
7484             # \cZ Control-Z
7485             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
7486              
7487             # any operator before div
7488             elsif (/\G (
7489             -- | \+\+ |
7490 0         0 [\)\}\]]
  14098         52085  
7491              
7492             ) /oxgc) { $slash = 'div'; return $1; }
7493              
7494             # yada-yada or triple-dot operator
7495             elsif (/\G (
7496 14098         70834 \.\.\.
  7         15  
7497              
7498             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
7499              
7500             # any operator before m//
7501              
7502             # //, //= (defined-or)
7503              
7504             # P.164 Logical Operators
7505             # in Chapter 10: More Control Structures
7506             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7507              
7508             # P.119 C-Style Logical (Short-Circuit) Operators
7509             # in Chapter 3: Unary and Binary Operators
7510             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7511              
7512             # (and so on)
7513              
7514             # ~~
7515              
7516             # P.221 The Smart Match Operator
7517             # in Chapter 15: Smart Matching and given-when
7518             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7519              
7520             # P.112 Smartmatch Operator
7521             # in Chapter 3: Unary and Binary Operators
7522             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7523              
7524             # (and so on)
7525              
7526             elsif (/\G ((?>
7527              
7528             !~~ | !~ | != | ! |
7529             %= | % |
7530             &&= | && | &= | &\.= | &\. | & |
7531             -= | -> | - |
7532             :(?>\s*)= |
7533             : |
7534             <<>> |
7535             <<= | <=> | <= | < |
7536             == | => | =~ | = |
7537             >>= | >> | >= | > |
7538             \*\*= | \*\* | \*= | \* |
7539             \+= | \+ |
7540             \.\. | \.= | \. |
7541             \/\/= | \/\/ |
7542             \/= | \/ |
7543             \? |
7544             \\ |
7545             \^= | \^\.= | \^\. | \^ |
7546             \b x= |
7547             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
7548             ~~ | ~\. | ~ |
7549             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
7550             \b(?: print )\b |
7551              
7552 7         28 [,;\(\{\[]
  23696         53993  
7553              
7554             )) /oxgc) { $slash = 'm//'; return $1; }
7555 23696         116035  
  37245         84199  
7556             # other any character
7557             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
7558              
7559 37245         225699 # system error
7560             else {
7561             die __FILE__, ": Oops, this shouldn't happen!\n";
7562             }
7563             }
7564              
7565 0     3084 0 0 # escape KPS9566 string
7566 3084         8973 sub e_string {
7567             my($string) = @_;
7568 3084         4724 my $e_string = '';
7569              
7570             local $slash = 'm//';
7571              
7572             # P.1024 Appendix W.10 Multibyte Processing
7573             # of ISBN 1-56592-224-7 CJKV Information Processing
7574 3084         5091 # (and so on)
7575              
7576             my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\$q_char|$q_char) /oxmsg;
7577 3084 100 66     29874  
7578 3084 50       26629 # without { ... }
7579 3014         6774 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
7580             if ($string !~ /<
7581             return $string;
7582             }
7583             }
7584 3014         7706  
7585 70 50       200 E_STRING_LOOP:
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
7586             while ($string !~ /\G \z/oxgc) {
7587             if (0) {
7588             }
7589 534         85748  
7590 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Ekps9566::PREMATCH()]}
7591 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
7592             $e_string .= q{Ekps9566::PREMATCH()};
7593             $slash = 'div';
7594             }
7595              
7596 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Ekps9566::MATCH()]}
7597 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
7598             $e_string .= q{Ekps9566::MATCH()};
7599             $slash = 'div';
7600             }
7601              
7602 0         0 # $', ${'} --> $', ${'}
7603 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
7604             $e_string .= $1;
7605             $slash = 'div';
7606             }
7607              
7608 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Ekps9566::POSTMATCH()]}
7609 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
7610             $e_string .= q{Ekps9566::POSTMATCH()};
7611             $slash = 'div';
7612             }
7613              
7614 0         0 # bareword
7615 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
7616             $e_string .= $1;
7617             $slash = 'div';
7618             }
7619              
7620 0         0 # $0 --> $0
7621 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
7622             $e_string .= $1;
7623             $slash = 'div';
7624 0         0 }
7625 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
7626             $e_string .= $1;
7627             $slash = 'div';
7628             }
7629              
7630 0         0 # $$ --> $$
7631 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
7632             $e_string .= $1;
7633             $slash = 'div';
7634             }
7635              
7636             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7637 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7638 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
7639             $e_string .= e_capture($1);
7640             $slash = 'div';
7641 0         0 }
7642 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
7643             $e_string .= e_capture($1);
7644             $slash = 'div';
7645             }
7646              
7647 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7648 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
7649             $e_string .= e_capture($1.'->'.$2);
7650             $slash = 'div';
7651             }
7652              
7653 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7654 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
7655             $e_string .= e_capture($1.'->'.$2);
7656             $slash = 'div';
7657             }
7658              
7659 0         0 # $$foo
7660 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
7661             $e_string .= e_capture($1);
7662             $slash = 'div';
7663             }
7664              
7665 0         0 # ${ foo }
7666 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
7667             $e_string .= '${' . $1 . '}';
7668             $slash = 'div';
7669             }
7670              
7671 0         0 # ${ ... }
7672 3         12 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
7673             $e_string .= e_capture($1);
7674             $slash = 'div';
7675             }
7676              
7677             # variable or function
7678 3         16 # $ @ % & * $ #
7679 0         0 elsif ($string =~ /\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
7680             $e_string .= $1;
7681             $slash = 'div';
7682             }
7683             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
7684 0         0 # $ @ # \ ' " / ? ( ) [ ] < >
7685 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
7686             $e_string .= $1;
7687             $slash = 'div';
7688             }
7689 0         0  
  0         0  
7690 0         0 # subroutines of package Ekps9566
  0         0  
7691 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
7692 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7693 0         0 elsif ($string =~ /\G \b KPS9566::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7694 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
7695 0         0 elsif ($string =~ /\G \b KPS9566::eval \b /oxgc) { $e_string .= 'eval KPS9566::escape'; $slash = 'm//'; }
  0         0  
7696 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
7697 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Ekps9566::chop'; $slash = 'm//'; }
  0         0  
7698 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
7699 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
7700 0         0 elsif ($string =~ /\G \b KPS9566::index \b /oxgc) { $e_string .= 'KPS9566::index'; $slash = 'm//'; }
  0         0  
7701 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Ekps9566::index'; $slash = 'm//'; }
  0         0  
7702 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
7703 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
7704 0         0 elsif ($string =~ /\G \b KPS9566::rindex \b /oxgc) { $e_string .= 'KPS9566::rindex'; $slash = 'm//'; }
  0         0  
7705 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Ekps9566::rindex'; $slash = 'm//'; }
  0         0  
7706 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ekps9566::lc'; $slash = 'm//'; }
  0         0  
7707 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ekps9566::lcfirst'; $slash = 'm//'; }
  0         0  
7708 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ekps9566::uc'; $slash = 'm//'; }
  0         0  
7709             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ekps9566::ucfirst'; $slash = 'm//'; }
7710 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ekps9566::fc'; $slash = 'm//'; }
  0         0  
7711 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7712 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7713 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7714 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7715 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7716 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7717             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7718             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7719 0         0  
  0         0  
7720 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7721 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7722 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7723 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7724 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7725 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7726             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7727             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7728 0         0  
  0         0  
7729 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7730 0         0 { $e_string .= "Ekps9566::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7731 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7732             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $e_string .= "Ekps9566::filetest qw($1),"; $slash = 'm//'; }
7733 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $e_string .= "Ekps9566::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7734 0         0  
  0         0  
7735 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Ekps9566::$1(" . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7736 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7737 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7738 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7739 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7740             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7741 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Ekps9566::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7742 0         0  
  0         0  
7743 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Ekps9566::$1(" . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7744 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7745 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7746 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7747 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7748             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7749             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Ekps9566::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7750 0         0  
  0         0  
7751 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7752 0         0 { $e_string .= "Ekps9566::$1($2)"; $slash = 'm//'; }
  0         0  
7753 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Ekps9566::$1($2)"; $slash = 'm//'; }
  0         0  
7754 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= "Ekps9566::$1"; $slash = 'm//'; }
  0         0  
7755 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "Ekps9566::$1(::"."$2)"; $slash = 'm//'; }
  0         0  
7756 0         0 elsif ($string =~ /\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-t $2"; $slash = 'm//'; }
  0         0  
7757             elsif ($string =~ /\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ekps9566::lstat'; $slash = 'm//'; }
7758             elsif ($string =~ /\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ekps9566::stat'; $slash = 'm//'; }
7759 0         0  
  0         0  
7760 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
7761 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7762 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7763 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7764 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7765 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7766             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
7767 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7768 0         0  
  0         0  
7769 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7770 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7771 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7772 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7773 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7774             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7775             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7776 0         0  
  0         0  
7777 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
7778 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7779 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
7780             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
7781 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7782 0         0  
  0         0  
7783 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7784 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7785 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ekps9566::chr'; $slash = 'm//'; }
  0         0  
7786 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7787 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
7788 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ekps9566::glob'; $slash = 'm//'; }
  0         0  
7789 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Ekps9566::lc_'; $slash = 'm//'; }
  0         0  
7790 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Ekps9566::lcfirst_'; $slash = 'm//'; }
  0         0  
7791 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Ekps9566::uc_'; $slash = 'm//'; }
  0         0  
7792 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Ekps9566::ucfirst_'; $slash = 'm//'; }
  0         0  
7793 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Ekps9566::fc_'; $slash = 'm//'; }
  0         0  
7794             elsif ($string =~ /\G \b lstat \b /oxgc) { $e_string .= 'Ekps9566::lstat_'; $slash = 'm//'; }
7795 0         0 elsif ($string =~ /\G \b stat \b /oxgc) { $e_string .= 'Ekps9566::stat_'; $slash = 'm//'; }
  0         0  
7796 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7797 0         0 \b /oxgc) { $e_string .= "Ekps9566::filetest_(qw($1))"; $slash = 'm//'; }
  0         0  
7798             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) \b /oxgc) { $e_string .= "Ekps9566::${1}_"; $slash = 'm//'; }
7799 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
7800 0         0  
  0         0  
7801 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7802 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7803 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Ekps9566::chr_'; $slash = 'm//'; }
  0         0  
7804 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7805 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
7806 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Ekps9566::glob_'; $slash = 'm//'; }
  0         0  
7807 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
7808 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
7809 0         0 elsif ($string =~ /\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Ekps9566::opendir$1*"; $slash = 'm//'; }
  0         0  
7810             elsif ($string =~ /\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Ekps9566::opendir$1*"; $slash = 'm//'; }
7811             elsif ($string =~ /\G \b unlink \b /oxgc) { $e_string .= 'Ekps9566::unlink'; $slash = 'm//'; }
7812              
7813 0         0 # chdir
7814             elsif ($string =~ /\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
7815 0         0 $slash = 'm//';
7816              
7817 0         0 $e_string .= 'Ekps9566::chdir';
7818 0         0  
7819             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7820             $e_string .= $1;
7821             }
7822 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
7823             # end of chdir
7824             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return $e_string; }
7825 0         0  
  0         0  
7826             # chdir scalar value
7827             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= e_string($1); next E_STRING_LOOP; }
7828              
7829 0 0       0 # chdir qq//
  0         0  
  0         0  
7830             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7831 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq# # --> qr # #
7832 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7833 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7834 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7835 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
7836 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
7837 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
7838 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
7839             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq','{','}',$2); next E_STRING_LOOP; } # qq | | --> qr { }
7840 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq * * --> qr * *
7841             }
7842             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7843             }
7844             }
7845              
7846 0 0       0 # chdir q//
  0         0  
  0         0  
7847             elsif ($string =~ /\G \b (q) \b /oxgc) {
7848 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q# # --> qr # #
7849 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7850 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7851 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7852 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
7853 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
7854 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
7855 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
7856             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q','{','}',$2); next E_STRING_LOOP; } # q | | --> qr { }
7857 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q * * --> qr * *
7858             }
7859             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7860             }
7861             }
7862              
7863 0         0 # chdir ''
7864 0         0 elsif ($string =~ /\G (\') /oxgc) {
7865 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7866 0         0 while ($string !~ /\G \z/oxgc) {
7867 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7868 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; }
7869             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_chdir_q('',"'","'",$q_string); next E_STRING_LOOP; }
7870 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7871             }
7872             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7873             }
7874              
7875 0         0 # chdir ""
7876 0         0 elsif ($string =~ /\G (\") /oxgc) {
7877 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
7878 0         0 while ($string !~ /\G \z/oxgc) {
7879 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
7880 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; }
7881             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_chdir('','"','"',$qq_string); next E_STRING_LOOP; }
7882 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
7883             }
7884             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7885             }
7886             }
7887              
7888 0         0 # split
7889             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
7890 0         0 $slash = 'm//';
7891 0         0  
7892 0         0 my $e = '';
7893             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7894             $e .= $1;
7895             }
7896 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7897             # end of split
7898             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Ekps9566::split' . $e; }
7899 0         0  
  0         0  
7900             # split scalar value
7901             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Ekps9566::split' . $e . e_string($1); next E_STRING_LOOP; }
7902 0         0  
  0         0  
7903 0         0 # split literal space
  0         0  
7904 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
7905 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7906 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7907 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7908 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7909 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7910 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
7911 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7912 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7913 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7914 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7915 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7916             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq {' '}; next E_STRING_LOOP; }
7917             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Ekps9566::split' . $e . qq {" "}; next E_STRING_LOOP; }
7918              
7919 0 0       0 # split qq//
  0         0  
  0         0  
7920             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7921 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
7922 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7923 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7924 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7925 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
7926 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
7927 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
7928 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
7929             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
7930 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
7931             }
7932             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7933             }
7934             }
7935              
7936 0 0       0 # split qr//
  0         0  
  0         0  
7937             elsif ($string =~ /\G \b (qr) \b /oxgc) {
7938 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
7939 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7940 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7941 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7942 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0         0  
7943 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0         0  
7944 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0         0  
7945 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0         0  
7946 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0         0  
7947             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
7948 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
7949             }
7950             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7951             }
7952             }
7953              
7954 0 0       0 # split q//
  0         0  
  0         0  
7955             elsif ($string =~ /\G \b (q) \b /oxgc) {
7956 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
7957 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7958 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7959 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7960 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
7961 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
7962 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
7963 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
7964             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
7965 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
7966             }
7967             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7968             }
7969             }
7970              
7971 0 0       0 # split m//
  0         0  
  0         0  
7972             elsif ($string =~ /\G \b (m) \b /oxgc) {
7973 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
7974 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7975 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7976 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7977 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0         0  
7978 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0         0  
7979 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0         0  
7980 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0         0  
7981 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0         0  
7982             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
7983 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
7984             }
7985             die __FILE__, ": Search pattern not terminated\n";
7986             }
7987             }
7988              
7989 0         0 # split ''
7990 0         0 elsif ($string =~ /\G (\') /oxgc) {
7991 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7992 0         0 while ($string !~ /\G \z/oxgc) {
7993 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7994 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
7995             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
7996 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7997             }
7998             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7999             }
8000              
8001 0         0 # split ""
8002 0         0 elsif ($string =~ /\G (\") /oxgc) {
8003 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
8004 0         0 while ($string !~ /\G \z/oxgc) {
8005 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
8006 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
8007             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
8008 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
8009             }
8010             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8011             }
8012              
8013 0         0 # split //
8014 0         0 elsif ($string =~ /\G (\/) /oxgc) {
8015 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
8016 0         0 while ($string !~ /\G \z/oxgc) {
8017 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
8018 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
8019             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
8020 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
8021             }
8022             die __FILE__, ": Search pattern not terminated\n";
8023             }
8024             }
8025              
8026 0         0 # qq//
8027 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
8028 0         0 my $ope = $1;
8029             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
8030             $e_string .= e_qq($ope,$1,$3,$2);
8031 0         0 }
8032 0         0 else {
8033 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8034 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8035 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8036 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
8037 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
8038 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
8039             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
8040 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
8041             }
8042             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8043             }
8044             }
8045              
8046 0         0 # qx//
8047 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
8048 0         0 my $ope = $1;
8049             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
8050             $e_string .= e_qq($ope,$1,$3,$2);
8051 0         0 }
8052 0         0 else {
8053 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8054 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8055 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8056 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
8057 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
8058 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
8059 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
8060             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
8061 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
8062             }
8063             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8064             }
8065             }
8066              
8067 0         0 # q//
8068 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
8069 0         0 my $ope = $1;
8070             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
8071             $e_string .= e_q($ope,$1,$3,$2);
8072 0         0 }
8073 0         0 else {
8074 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8075 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8076 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8077 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
8078 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
8079 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
8080             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
8081 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
8082             }
8083             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8084             }
8085             }
8086 0         0  
8087             # ''
8088             elsif ($string =~ /\G (?
8089 44         175  
8090             # ""
8091             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8092 6         56  
8093             # ``
8094             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8095 0         0  
8096             # <<>> (a safer ARGV)
8097             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
8098 0         0  
8099             # <<= <=> <= < operator
8100             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
8101 0         0  
8102             #
8103             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
8104              
8105 0         0 # --- glob
8106             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
8107             $e_string .= 'Ekps9566::glob("' . $1 . '")';
8108             }
8109              
8110 0         0 # << (bit shift) --- not here document
8111 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
8112             $slash = 'm//';
8113             $e_string .= $1;
8114             }
8115              
8116 0         0 # <<~'HEREDOC'
8117 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
8118 0         0 $slash = 'm//';
8119             my $here_quote = $1;
8120             my $delimiter = $2;
8121 0 0       0  
8122 0         0 # get here document
8123 0         0 if ($here_script eq '') {
8124             $here_script = CORE::substr $_, pos $_;
8125 0 0       0 $here_script =~ s/.*?\n//oxm;
8126 0         0 }
8127 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8128 0         0 my $heredoc = $1;
8129 0         0 my $indent = $2;
8130 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8131             push @heredoc, $heredoc . qq{\n$delimiter\n};
8132             push @heredoc_delimiter, qq{\\s*$delimiter};
8133 0         0 }
8134             else {
8135 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8136             }
8137             $e_string .= qq{<<'$delimiter'};
8138             }
8139              
8140 0         0 # <<~\HEREDOC
8141 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
8142 0         0 $slash = 'm//';
8143             my $here_quote = $1;
8144             my $delimiter = $2;
8145 0 0       0  
8146 0         0 # get here document
8147 0         0 if ($here_script eq '') {
8148             $here_script = CORE::substr $_, pos $_;
8149 0 0       0 $here_script =~ s/.*?\n//oxm;
8150 0         0 }
8151 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8152 0         0 my $heredoc = $1;
8153 0         0 my $indent = $2;
8154 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8155             push @heredoc, $heredoc . qq{\n$delimiter\n};
8156             push @heredoc_delimiter, qq{\\s*$delimiter};
8157 0         0 }
8158             else {
8159 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8160             }
8161             $e_string .= qq{<<\\$delimiter};
8162             }
8163              
8164 0         0 # <<~"HEREDOC"
8165 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
8166 0         0 $slash = 'm//';
8167             my $here_quote = $1;
8168             my $delimiter = $2;
8169 0 0       0  
8170 0         0 # get here document
8171 0         0 if ($here_script eq '') {
8172             $here_script = CORE::substr $_, pos $_;
8173 0 0       0 $here_script =~ s/.*?\n//oxm;
8174 0         0 }
8175 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8176 0         0 my $heredoc = $1;
8177 0         0 my $indent = $2;
8178 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8179             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8180             push @heredoc_delimiter, qq{\\s*$delimiter};
8181 0         0 }
8182             else {
8183 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8184             }
8185             $e_string .= qq{<<"$delimiter"};
8186             }
8187              
8188 0         0 # <<~HEREDOC
8189 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
8190 0         0 $slash = 'm//';
8191             my $here_quote = $1;
8192             my $delimiter = $2;
8193 0 0       0  
8194 0         0 # get here document
8195 0         0 if ($here_script eq '') {
8196             $here_script = CORE::substr $_, pos $_;
8197 0 0       0 $here_script =~ s/.*?\n//oxm;
8198 0         0 }
8199 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8200 0         0 my $heredoc = $1;
8201 0         0 my $indent = $2;
8202 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8203             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8204             push @heredoc_delimiter, qq{\\s*$delimiter};
8205 0         0 }
8206             else {
8207 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8208             }
8209             $e_string .= qq{<<$delimiter};
8210             }
8211              
8212 0         0 # <<~`HEREDOC`
8213 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
8214 0         0 $slash = 'm//';
8215             my $here_quote = $1;
8216             my $delimiter = $2;
8217 0 0       0  
8218 0         0 # get here document
8219 0         0 if ($here_script eq '') {
8220             $here_script = CORE::substr $_, pos $_;
8221 0 0       0 $here_script =~ s/.*?\n//oxm;
8222 0         0 }
8223 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8224 0         0 my $heredoc = $1;
8225 0         0 my $indent = $2;
8226 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8227             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8228             push @heredoc_delimiter, qq{\\s*$delimiter};
8229 0         0 }
8230             else {
8231 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8232             }
8233             $e_string .= qq{<<`$delimiter`};
8234             }
8235              
8236 0         0 # <<'HEREDOC'
8237 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
8238 0         0 $slash = 'm//';
8239             my $here_quote = $1;
8240             my $delimiter = $2;
8241 0 0       0  
8242 0         0 # get here document
8243 0         0 if ($here_script eq '') {
8244             $here_script = CORE::substr $_, pos $_;
8245 0 0       0 $here_script =~ s/.*?\n//oxm;
8246 0         0 }
8247 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8248             push @heredoc, $1 . qq{\n$delimiter\n};
8249             push @heredoc_delimiter, $delimiter;
8250 0         0 }
8251             else {
8252 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8253             }
8254             $e_string .= $here_quote;
8255             }
8256              
8257 0         0 # <<\HEREDOC
8258 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
8259 0         0 $slash = 'm//';
8260             my $here_quote = $1;
8261             my $delimiter = $2;
8262 0 0       0  
8263 0         0 # get here document
8264 0         0 if ($here_script eq '') {
8265             $here_script = CORE::substr $_, pos $_;
8266 0 0       0 $here_script =~ s/.*?\n//oxm;
8267 0         0 }
8268 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8269             push @heredoc, $1 . qq{\n$delimiter\n};
8270             push @heredoc_delimiter, $delimiter;
8271 0         0 }
8272             else {
8273 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8274             }
8275             $e_string .= $here_quote;
8276             }
8277              
8278 0         0 # <<"HEREDOC"
8279 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
8280 0         0 $slash = 'm//';
8281             my $here_quote = $1;
8282             my $delimiter = $2;
8283 0 0       0  
8284 0         0 # get here document
8285 0         0 if ($here_script eq '') {
8286             $here_script = CORE::substr $_, pos $_;
8287 0 0       0 $here_script =~ s/.*?\n//oxm;
8288 0         0 }
8289 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8290             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8291             push @heredoc_delimiter, $delimiter;
8292 0         0 }
8293             else {
8294 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8295             }
8296             $e_string .= $here_quote;
8297             }
8298              
8299 0         0 # <
8300 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
8301 0         0 $slash = 'm//';
8302             my $here_quote = $1;
8303             my $delimiter = $2;
8304 0 0       0  
8305 0         0 # get here document
8306 0         0 if ($here_script eq '') {
8307             $here_script = CORE::substr $_, pos $_;
8308 0 0       0 $here_script =~ s/.*?\n//oxm;
8309 0         0 }
8310 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8311             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8312             push @heredoc_delimiter, $delimiter;
8313 0         0 }
8314             else {
8315 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8316             }
8317             $e_string .= $here_quote;
8318             }
8319              
8320 0         0 # <<`HEREDOC`
8321 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
8322 0         0 $slash = 'm//';
8323             my $here_quote = $1;
8324             my $delimiter = $2;
8325 0 0       0  
8326 0         0 # get here document
8327 0         0 if ($here_script eq '') {
8328             $here_script = CORE::substr $_, pos $_;
8329 0 0       0 $here_script =~ s/.*?\n//oxm;
8330 0         0 }
8331 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8332             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8333             push @heredoc_delimiter, $delimiter;
8334 0         0 }
8335             else {
8336 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8337             }
8338             $e_string .= $here_quote;
8339             }
8340              
8341             # any operator before div
8342             elsif ($string =~ /\G (
8343             -- | \+\+ |
8344 0         0 [\)\}\]]
  71         143  
8345              
8346             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
8347              
8348             # yada-yada or triple-dot operator
8349             elsif ($string =~ /\G (
8350 71         331 \.\.\.
  0         0  
8351              
8352             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
8353              
8354             # any operator before m//
8355             elsif ($string =~ /\G ((?>
8356              
8357             !~~ | !~ | != | ! |
8358             %= | % |
8359             &&= | && | &= | &\.= | &\. | & |
8360             -= | -> | - |
8361             :(?>\s*)= |
8362             : |
8363             <<>> |
8364             <<= | <=> | <= | < |
8365             == | => | =~ | = |
8366             >>= | >> | >= | > |
8367             \*\*= | \*\* | \*= | \* |
8368             \+= | \+ |
8369             \.\. | \.= | \. |
8370             \/\/= | \/\/ |
8371             \/= | \/ |
8372             \? |
8373             \\ |
8374             \^= | \^\.= | \^\. | \^ |
8375             \b x= |
8376             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
8377             ~~ | ~\. | ~ |
8378             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
8379             \b(?: print )\b |
8380              
8381 0         0 [,;\(\{\[]
  103         292  
8382              
8383             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
8384 103         911  
8385             # other any character
8386             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
8387              
8388 307         1564 # system error
8389             else {
8390             die __FILE__, ": Oops, this shouldn't happen!\n";
8391             }
8392 0         0 }
8393              
8394             return $e_string;
8395             }
8396              
8397             #
8398             # character class
8399 70     5350 0 325 #
8400             sub character_class {
8401 5350 100       10440 my($char,$modifier) = @_;
8402 5350 100       8571  
8403 115         511 if ($char eq '.') {
8404             if ($modifier =~ /s/) {
8405             return '${Ekps9566::dot_s}';
8406 23         64 }
8407             else {
8408             return '${Ekps9566::dot}';
8409             }
8410 92         192 }
8411             else {
8412             return Ekps9566::classic_character_class($char);
8413             }
8414             }
8415              
8416             #
8417             # escape capture ($1, $2, $3, ...)
8418             #
8419 5235     637 0 9173 sub e_capture {
8420 637         2808  
8421             return join '', '${Ekps9566::capture(', $_[0], ')}';
8422             return join '', '${', $_[0], '}';
8423             }
8424              
8425             #
8426             # escape transliteration (tr/// or y///)
8427 0     11 0 0 #
8428 11         61 sub e_tr {
8429 11   100     24 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
8430             my $e_tr = '';
8431 11         30 $modifier ||= '';
8432              
8433             $slash = 'div';
8434 11         16  
8435             # quote character class 1
8436             $charclass = q_tr($charclass);
8437 11         30  
8438             # quote character class 2
8439             $charclass2 = q_tr($charclass2);
8440 11 50       23  
8441 11 0       34 # /b /B modifier
8442 0         0 if ($modifier =~ tr/bB//d) {
8443             if ($variable eq '') {
8444             $e_tr = qq{tr$charclass$e$charclass2$modifier};
8445 0         0 }
8446             else {
8447             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
8448             }
8449 0 100       0 }
8450 11         30 else {
8451             if ($variable eq '') {
8452             $e_tr = qq{Ekps9566::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
8453 2         8 }
8454             else {
8455             $e_tr = qq{Ekps9566::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
8456             }
8457             }
8458 9         30  
8459 11         18 # clear tr/// variable
8460             $tr_variable = '';
8461 11         20 $bind_operator = '';
8462              
8463             return $e_tr;
8464             }
8465              
8466             #
8467             # quote for escape transliteration (tr/// or y///)
8468 11     22 0 65 #
8469             sub q_tr {
8470             my($charclass) = @_;
8471 22 50       30  
    0          
    0          
    0          
    0          
    0          
8472 22         48 # quote character class
8473             if ($charclass !~ /'/oxms) {
8474             return e_q('', "'", "'", $charclass); # --> q' '
8475 22         39 }
8476             elsif ($charclass !~ /\//oxms) {
8477             return e_q('q', '/', '/', $charclass); # --> q/ /
8478 0         0 }
8479             elsif ($charclass !~ /\#/oxms) {
8480             return e_q('q', '#', '#', $charclass); # --> q# #
8481 0         0 }
8482             elsif ($charclass !~ /[\<\>]/oxms) {
8483             return e_q('q', '<', '>', $charclass); # --> q< >
8484 0         0 }
8485             elsif ($charclass !~ /[\(\)]/oxms) {
8486             return e_q('q', '(', ')', $charclass); # --> q( )
8487 0         0 }
8488             elsif ($charclass !~ /[\{\}]/oxms) {
8489             return e_q('q', '{', '}', $charclass); # --> q{ }
8490 0         0 }
8491 0 0       0 else {
8492 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8493             if ($charclass !~ /\Q$char\E/xms) {
8494             return e_q('q', $char, $char, $charclass);
8495             }
8496             }
8497 0         0 }
8498              
8499             return e_q('q', '{', '}', $charclass);
8500             }
8501              
8502             #
8503             # escape q string (q//, '')
8504 0     3951 0 0 #
8505             sub e_q {
8506 3951         11097 my($ope,$delimiter,$end_delimiter,$string) = @_;
8507              
8508 3951         6215 $slash = 'div';
8509 3951         27668  
8510             my @char = $string =~ / \G (?>$q_char) /oxmsg;
8511             for (my $i=0; $i <= $#char; $i++) {
8512 3951 100 100     13189  
    100 100        
8513 21189         151219 # escape last octet of multiple-octet
8514             if ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
8515             $char[$i] = $1 . '\\' . $2;
8516 1         5 }
8517             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8518             $char[$i] = $1 . '\\' . $2;
8519 22 100 100     98 }
8520 3951         16744 }
8521             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8522             $char[-1] = $1 . '\\' . $2;
8523 204         646 }
8524 3951         23794  
8525             return join '', $ope, $delimiter, @char, $end_delimiter;
8526             return join '', $ope, $delimiter, $string, $end_delimiter;
8527             }
8528              
8529             #
8530             # escape qq string (qq//, "", qx//, ``)
8531 0     9504 0 0 #
8532             sub e_qq {
8533 9504         24109 my($ope,$delimiter,$end_delimiter,$string) = @_;
8534              
8535 9504         14933 $slash = 'div';
8536 9504         12154  
8537             my $left_e = 0;
8538             my $right_e = 0;
8539 9504         12191  
8540             # split regexp
8541             my @char = $string =~ /\G((?>
8542             [^\x81-\xFE\\\$]|[\x81-\xFE][\x00-\xFF] |
8543             \\x\{ (?>[0-9A-Fa-f]+) \} |
8544             \\o\{ (?>[0-7]+) \} |
8545             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8546             \\ $q_char |
8547             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8548             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8549             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8550             \$ (?>\s* [0-9]+) |
8551             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8552             \$ \$ (?![\w\{]) |
8553             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8554             $q_char
8555 9504         390993 ))/oxmsg;
8556              
8557             for (my $i=0; $i <= $#char; $i++) {
8558 9504 50 66     66896  
    50 33        
    100          
    100          
    50          
8559 307480         1078978 # "\L\u" --> "\u\L"
8560             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8561             @char[$i,$i+1] = @char[$i+1,$i];
8562             }
8563              
8564 0         0 # "\U\l" --> "\l\U"
8565             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8566             @char[$i,$i+1] = @char[$i+1,$i];
8567             }
8568              
8569 0         0 # octal escape sequence
8570             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8571             $char[$i] = Ekps9566::octchr($1);
8572             }
8573              
8574 1         4 # hexadecimal escape sequence
8575             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8576             $char[$i] = Ekps9566::hexchr($1);
8577             }
8578              
8579 1         4 # \N{CHARNAME} --> N{CHARNAME}
8580             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8581             $char[$i] = $1;
8582 0 100       0 }
    100          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
8583              
8584             if (0) {
8585             }
8586              
8587             # escape last octet of multiple-octet
8588 307480         3175028 # my $metachar = qr/[\@\\\|]/oxms; # '|' is for qx//, ``, open(), and system()
8589 0         0 # variable $delimiter and $end_delimiter can be ''
8590             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\@\\\|$delimiter$end_delimiter]) \z/xms) {
8591             $char[$i] = $1 . '\\' . $2;
8592             }
8593              
8594             # \F
8595             #
8596             # P.69 Table 2-6. Translation escapes
8597             # in Chapter 2: Bits and Pieces
8598             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8599             # (and so on)
8600              
8601 1342 50       4928 # \u \l \U \L \F \Q \E
8602 647         1755 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8603             if ($right_e < $left_e) {
8604             $char[$i] = '\\' . $char[$i];
8605             }
8606             }
8607             elsif ($char[$i] eq '\u') {
8608              
8609             # "STRING @{[ LIST EXPR ]} MORE STRING"
8610              
8611             # P.257 Other Tricks You Can Do with Hard References
8612             # in Chapter 8: References
8613             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
8614              
8615             # P.353 Other Tricks You Can Do with Hard References
8616             # in Chapter 8: References
8617             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8618              
8619 0         0 # (and so on)
8620 0         0  
8621             $char[$i] = '@{[Ekps9566::ucfirst qq<';
8622             $left_e++;
8623 0         0 }
8624 0         0 elsif ($char[$i] eq '\l') {
8625             $char[$i] = '@{[Ekps9566::lcfirst qq<';
8626             $left_e++;
8627 0         0 }
8628 0         0 elsif ($char[$i] eq '\U') {
8629             $char[$i] = '@{[Ekps9566::uc qq<';
8630             $left_e++;
8631 0         0 }
8632 6         8 elsif ($char[$i] eq '\L') {
8633             $char[$i] = '@{[Ekps9566::lc qq<';
8634             $left_e++;
8635 6         13 }
8636 9         18 elsif ($char[$i] eq '\F') {
8637             $char[$i] = '@{[Ekps9566::fc qq<';
8638             $left_e++;
8639 9         23 }
8640 0         0 elsif ($char[$i] eq '\Q') {
8641             $char[$i] = '@{[CORE::quotemeta qq<';
8642             $left_e++;
8643 0 50       0 }
8644 12         26 elsif ($char[$i] eq '\E') {
8645 12         17 if ($right_e < $left_e) {
8646             $char[$i] = '>]}';
8647             $right_e++;
8648 12         22 }
8649             else {
8650             $char[$i] = '';
8651             }
8652 0         0 }
8653 0 0       0 elsif ($char[$i] eq '\Q') {
8654 0         0 while (1) {
8655             if (++$i > $#char) {
8656 0 0       0 last;
8657 0         0 }
8658             if ($char[$i] eq '\E') {
8659             last;
8660             }
8661             }
8662             }
8663             elsif ($char[$i] eq '\E') {
8664             }
8665              
8666             # $0 --> $0
8667             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8668             }
8669             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8670             }
8671              
8672             # $$ --> $$
8673             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8674             }
8675              
8676             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8677 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8678             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8679             $char[$i] = e_capture($1);
8680 415         1294 }
8681             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8682             $char[$i] = e_capture($1);
8683             }
8684              
8685 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8686             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8687             $char[$i] = e_capture($1.'->'.$2);
8688             }
8689              
8690 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8691             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8692             $char[$i] = e_capture($1.'->'.$2);
8693             }
8694              
8695 0         0 # $$foo
8696             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8697             $char[$i] = e_capture($1);
8698             }
8699              
8700 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ekps9566::PREMATCH()
8701             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8702             $char[$i] = '@{[Ekps9566::PREMATCH()]}';
8703             }
8704              
8705 44         150 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ekps9566::MATCH()
8706             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8707             $char[$i] = '@{[Ekps9566::MATCH()]}';
8708             }
8709              
8710 45         150 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ekps9566::POSTMATCH()
8711             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8712             $char[$i] = '@{[Ekps9566::POSTMATCH()]}';
8713             }
8714              
8715             # ${ foo } --> ${ foo }
8716             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8717             }
8718              
8719 33         105 # ${ ... }
8720             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8721             $char[$i] = e_capture($1);
8722             }
8723             }
8724 0 100       0  
8725 9504         20197 # return string
8726             if ($left_e > $right_e) {
8727 3         18 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
8728             }
8729             return join '', $ope, $delimiter, @char, $end_delimiter;
8730             }
8731              
8732             #
8733             # escape qw string (qw//)
8734 9501     34 0 88920 #
8735             sub e_qw {
8736 34         248 my($ope,$delimiter,$end_delimiter,$string) = @_;
8737              
8738             $slash = 'div';
8739 34         88  
  34         355  
8740 621 50       1159 # choice again delimiter
    0          
    0          
    0          
    0          
8741 34         181 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
8742             if (not $octet{$end_delimiter}) {
8743             return join '', $ope, $delimiter, $string, $end_delimiter;
8744 34         245 }
8745             elsif (not $octet{')'}) {
8746             return join '', $ope, '(', $string, ')';
8747 0         0 }
8748             elsif (not $octet{'}'}) {
8749             return join '', $ope, '{', $string, '}';
8750 0         0 }
8751             elsif (not $octet{']'}) {
8752             return join '', $ope, '[', $string, ']';
8753 0         0 }
8754             elsif (not $octet{'>'}) {
8755             return join '', $ope, '<', $string, '>';
8756 0         0 }
8757 0 0       0 else {
8758 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8759             if (not $octet{$char}) {
8760             return join '', $ope, $char, $string, $char;
8761             }
8762             }
8763             }
8764 0         0  
8765 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
8766 0         0 my @string = CORE::split(/\s+/, $string);
8767 0         0 for my $string (@string) {
8768 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
8769 0         0 for my $octet (@octet) {
8770             if ($octet =~ /\A (['\\]) \z/oxms) {
8771             $octet = '\\' . $1;
8772 0         0 }
8773             }
8774 0         0 $string = join '', @octet;
  0         0  
8775             }
8776             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
8777             }
8778              
8779             #
8780             # escape here document (<<"HEREDOC", <
8781 0     108 0 0 #
8782             sub e_heredoc {
8783 108         334 my($string) = @_;
8784              
8785 108         192 $slash = 'm//';
8786              
8787 108         370 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
8788 108         204  
8789             my $left_e = 0;
8790             my $right_e = 0;
8791 108         151  
8792             # split regexp
8793             my @char = $string =~ /\G((?>
8794             [^\x81-\xFE\\\$]|[\x81-\xFE][\x00-\xFF] |
8795             \\x\{ (?>[0-9A-Fa-f]+) \} |
8796             \\o\{ (?>[0-7]+) \} |
8797             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8798             \\ $q_char |
8799             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8800             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8801             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8802             \$ (?>\s* [0-9]+) |
8803             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8804             \$ \$ (?![\w\{]) |
8805             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8806             $q_char
8807 108         10330 ))/oxmsg;
8808              
8809             for (my $i=0; $i <= $#char; $i++) {
8810 108 50 66     536  
    50 33        
    100          
    100          
    50          
8811 3303         10308 # "\L\u" --> "\u\L"
8812             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8813             @char[$i,$i+1] = @char[$i+1,$i];
8814             }
8815              
8816 0         0 # "\U\l" --> "\l\U"
8817             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8818             @char[$i,$i+1] = @char[$i+1,$i];
8819             }
8820              
8821 0         0 # octal escape sequence
8822             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8823             $char[$i] = Ekps9566::octchr($1);
8824             }
8825              
8826 1         4 # hexadecimal escape sequence
8827             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8828             $char[$i] = Ekps9566::hexchr($1);
8829             }
8830              
8831 1         2 # \N{CHARNAME} --> N{CHARNAME}
8832             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8833             $char[$i] = $1;
8834 0 100       0 }
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
8835              
8836             if (0) {
8837             }
8838 3303         30822  
8839 0         0 # escape character
8840             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
8841             $char[$i] = $1 . '\\' . $2;
8842             }
8843              
8844 57 50       230 # \u \l \U \L \F \Q \E
8845 72         137 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8846             if ($right_e < $left_e) {
8847             $char[$i] = '\\' . $char[$i];
8848             }
8849 0         0 }
8850 0         0 elsif ($char[$i] eq '\u') {
8851             $char[$i] = '@{[Ekps9566::ucfirst qq<';
8852             $left_e++;
8853 0         0 }
8854 0         0 elsif ($char[$i] eq '\l') {
8855             $char[$i] = '@{[Ekps9566::lcfirst qq<';
8856             $left_e++;
8857 0         0 }
8858 0         0 elsif ($char[$i] eq '\U') {
8859             $char[$i] = '@{[Ekps9566::uc qq<';
8860             $left_e++;
8861 0         0 }
8862 6         8 elsif ($char[$i] eq '\L') {
8863             $char[$i] = '@{[Ekps9566::lc qq<';
8864             $left_e++;
8865 6         11 }
8866 0         0 elsif ($char[$i] eq '\F') {
8867             $char[$i] = '@{[Ekps9566::fc qq<';
8868             $left_e++;
8869 0         0 }
8870 0         0 elsif ($char[$i] eq '\Q') {
8871             $char[$i] = '@{[CORE::quotemeta qq<';
8872             $left_e++;
8873 0 50       0 }
8874 3         6 elsif ($char[$i] eq '\E') {
8875 3         4 if ($right_e < $left_e) {
8876             $char[$i] = '>]}';
8877             $right_e++;
8878 3         6 }
8879             else {
8880             $char[$i] = '';
8881             }
8882 0         0 }
8883 0 0       0 elsif ($char[$i] eq '\Q') {
8884 0         0 while (1) {
8885             if (++$i > $#char) {
8886 0 0       0 last;
8887 0         0 }
8888             if ($char[$i] eq '\E') {
8889             last;
8890             }
8891             }
8892             }
8893             elsif ($char[$i] eq '\E') {
8894             }
8895              
8896             # $0 --> $0
8897             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8898             }
8899             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8900             }
8901              
8902             # $$ --> $$
8903             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8904             }
8905              
8906             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8907 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8908             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8909             $char[$i] = e_capture($1);
8910 0         0 }
8911             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8912             $char[$i] = e_capture($1);
8913             }
8914              
8915 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8916             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8917             $char[$i] = e_capture($1.'->'.$2);
8918             }
8919              
8920 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8921             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8922             $char[$i] = e_capture($1.'->'.$2);
8923             }
8924              
8925 0         0 # $$foo
8926             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8927             $char[$i] = e_capture($1);
8928             }
8929              
8930 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ekps9566::PREMATCH()
8931             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8932             $char[$i] = '@{[Ekps9566::PREMATCH()]}';
8933             }
8934              
8935 8         57 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ekps9566::MATCH()
8936             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8937             $char[$i] = '@{[Ekps9566::MATCH()]}';
8938             }
8939              
8940 8         47 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ekps9566::POSTMATCH()
8941             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8942             $char[$i] = '@{[Ekps9566::POSTMATCH()]}';
8943             }
8944              
8945             # ${ foo } --> ${ foo }
8946             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8947             }
8948              
8949 6         36 # ${ ... }
8950             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8951             $char[$i] = e_capture($1);
8952             }
8953             }
8954 0 100       0  
8955 108         421 # return string
8956             if ($left_e > $right_e) {
8957 3         26 return join '', @char, '>]}' x ($left_e - $right_e);
8958             }
8959             return join '', @char;
8960             }
8961              
8962             #
8963             # escape regexp (m//, qr//)
8964 105     1833 0 829 #
8965 1833   100     10806 sub e_qr {
8966             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
8967 1833         7182 $modifier ||= '';
8968 1833 50       4166  
8969 1833         5198 $modifier =~ tr/p//d;
8970 0         0 if ($modifier =~ /([adlu])/oxms) {
8971 0 0       0 my $line = 0;
8972 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
8973 0         0 if ($filename ne __FILE__) {
8974             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
8975             last;
8976 0         0 }
8977             }
8978             die qq{Unsupported modifier "$1" used at line $line.\n};
8979 0         0 }
8980              
8981             $slash = 'div';
8982 1833 100       3155  
    100          
8983 1833         6200 # literal null string pattern
8984 8         13 if ($string eq '') {
8985 8         10 $modifier =~ tr/bB//d;
8986             $modifier =~ tr/i//d;
8987             return join '', $ope, $delimiter, $end_delimiter, $modifier;
8988             }
8989              
8990             # /b /B modifier
8991             elsif ($modifier =~ tr/bB//d) {
8992 8 50       39  
8993 240         766 # choice again delimiter
8994 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
8995 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
8996 0         0 my %octet = map {$_ => 1} @char;
8997 0         0 if (not $octet{')'}) {
8998             $delimiter = '(';
8999             $end_delimiter = ')';
9000 0         0 }
9001 0         0 elsif (not $octet{'}'}) {
9002             $delimiter = '{';
9003             $end_delimiter = '}';
9004 0         0 }
9005 0         0 elsif (not $octet{']'}) {
9006             $delimiter = '[';
9007             $end_delimiter = ']';
9008 0         0 }
9009 0         0 elsif (not $octet{'>'}) {
9010             $delimiter = '<';
9011             $end_delimiter = '>';
9012 0         0 }
9013 0 0       0 else {
9014 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9015 0         0 if (not $octet{$char}) {
9016 0         0 $delimiter = $char;
9017             $end_delimiter = $char;
9018             last;
9019             }
9020             }
9021             }
9022 0 100 100     0 }
9023 240         1718  
9024             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9025             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
9026 90         508 }
9027             else {
9028             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9029             }
9030 150 100       916 }
9031 1585         4275  
9032             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9033             my $metachar = qr/[\@\\|[\]{^]/oxms;
9034 1585         6580  
9035             # split regexp
9036             my @char = $string =~ /\G((?>
9037             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
9038             \\x (?>[0-9A-Fa-f]{1,2}) |
9039             \\ (?>[0-7]{2,3}) |
9040             \\c [\x40-\x5F] |
9041             \\x\{ (?>[0-9A-Fa-f]+) \} |
9042             \\o\{ (?>[0-7]+) \} |
9043             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9044             \\ $q_char |
9045             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9046             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9047             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9048             [\$\@] $qq_variable |
9049             \$ (?>\s* [0-9]+) |
9050             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9051             \$ \$ (?![\w\{]) |
9052             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9053             \[\^ |
9054             \[\: (?>[a-z]+) :\] |
9055             \[\:\^ (?>[a-z]+) :\] |
9056             \(\? |
9057             $q_char
9058             ))/oxmsg;
9059 1585 50       139570  
9060 1585         26316 # choice again delimiter
  0         0  
9061 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9062 0         0 my %octet = map {$_ => 1} @char;
9063 0         0 if (not $octet{')'}) {
9064             $delimiter = '(';
9065             $end_delimiter = ')';
9066 0         0 }
9067 0         0 elsif (not $octet{'}'}) {
9068             $delimiter = '{';
9069             $end_delimiter = '}';
9070 0         0 }
9071 0         0 elsif (not $octet{']'}) {
9072             $delimiter = '[';
9073             $end_delimiter = ']';
9074 0         0 }
9075 0         0 elsif (not $octet{'>'}) {
9076             $delimiter = '<';
9077             $end_delimiter = '>';
9078 0         0 }
9079 0 0       0 else {
9080 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9081 0         0 if (not $octet{$char}) {
9082 0         0 $delimiter = $char;
9083             $end_delimiter = $char;
9084             last;
9085             }
9086             }
9087             }
9088 0         0 }
9089 1585         2736  
9090 1585         2682 my $left_e = 0;
9091             my $right_e = 0;
9092             for (my $i=0; $i <= $#char; $i++) {
9093 1585 50 66     5836  
    50 66        
    100          
    100          
    100          
    100          
9094 5430         30359 # "\L\u" --> "\u\L"
9095             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9096             @char[$i,$i+1] = @char[$i+1,$i];
9097             }
9098              
9099 0         0 # "\U\l" --> "\l\U"
9100             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9101             @char[$i,$i+1] = @char[$i+1,$i];
9102             }
9103              
9104 0         0 # octal escape sequence
9105             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9106             $char[$i] = Ekps9566::octchr($1);
9107             }
9108              
9109 1         3 # hexadecimal escape sequence
9110             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9111             $char[$i] = Ekps9566::hexchr($1);
9112             }
9113              
9114             # \b{...} --> b\{...}
9115             # \B{...} --> B\{...}
9116             # \N{CHARNAME} --> N\{CHARNAME}
9117             # \p{PROPERTY} --> p\{PROPERTY}
9118 1         3 # \P{PROPERTY} --> P\{PROPERTY}
9119             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9120             $char[$i] = $1 . '\\' . $2;
9121             }
9122              
9123 6         29 # \p, \P, \X --> p, P, X
9124             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9125             $char[$i] = $1;
9126 4 100 100     12 }
    100 100        
    100 100        
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
9127              
9128             if (0) {
9129             }
9130 5430         41662  
9131 0         0 # escape last octet of multiple-octet
9132             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9133             $char[$i] = $1 . '\\' . $2;
9134             }
9135              
9136 77 50 33     401 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
9137 6         159 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9138             if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
9139             $char[$i] .= join '', splice @char, $i+1, 3;
9140 0         0 }
9141             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
9142             $char[$i] .= join '', splice @char, $i+1, 2;
9143 0         0 }
9144             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
9145             $char[$i] .= join '', splice @char, $i+1, 1;
9146             }
9147             }
9148              
9149 0         0 # open character class [...]
9150             elsif ($char[$i] eq '[') {
9151             my $left = $i;
9152              
9153             # [] make die "Unmatched [] in regexp ...\n"
9154 586 100       963 # (and so on)
9155 586         1672  
9156             if ($char[$i+1] eq ']') {
9157             $i++;
9158 3         6 }
9159 586 50       874  
9160 2583         4115 while (1) {
9161             if (++$i > $#char) {
9162 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9163 2583         4291 }
9164             if ($char[$i] eq ']') {
9165             my $right = $i;
9166 586 100       730  
9167 586         3499 # [...]
  90         204  
9168             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9169             splice @char, $left, $right-$left+1, sprintf(q{@{[Ekps9566::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9170 270         446 }
9171             else {
9172             splice @char, $left, $right-$left+1, Ekps9566::charlist_qr(@char[$left+1..$right-1], $modifier);
9173 496         2333 }
9174 586         1181  
9175             $i = $left;
9176             last;
9177             }
9178             }
9179             }
9180              
9181 586         2135 # open character class [^...]
9182             elsif ($char[$i] eq '[^') {
9183             my $left = $i;
9184              
9185             # [^] make die "Unmatched [] in regexp ...\n"
9186 328 100       1731 # (and so on)
9187 328         883  
9188             if ($char[$i+1] eq ']') {
9189             $i++;
9190 5         7 }
9191 328 50       506  
9192 1447         2183 while (1) {
9193             if (++$i > $#char) {
9194 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9195 1447         2379 }
9196             if ($char[$i] eq ']') {
9197             my $right = $i;
9198 328 100       427  
9199 328         1982 # [^...]
  90         210  
9200             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9201             splice @char, $left, $right-$left+1, sprintf(q{@{[Ekps9566::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9202 270         428 }
9203             else {
9204             splice @char, $left, $right-$left+1, Ekps9566::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9205 238         1102 }
9206 328         699  
9207             $i = $left;
9208             last;
9209             }
9210             }
9211             }
9212              
9213 328         17064 # rewrite character class or escape character
9214             elsif (my $char = character_class($char[$i],$modifier)) {
9215             $char[$i] = $char;
9216             }
9217              
9218 215 50       598 # /i modifier
9219 238         538 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ekps9566::uc($char[$i]) ne Ekps9566::fc($char[$i]))) {
9220             if (CORE::length(Ekps9566::fc($char[$i])) == 1) {
9221             $char[$i] = '[' . Ekps9566::uc($char[$i]) . Ekps9566::fc($char[$i]) . ']';
9222 238         453 }
9223             else {
9224             $char[$i] = '(?:' . Ekps9566::uc($char[$i]) . '|' . Ekps9566::fc($char[$i]) . ')';
9225             }
9226             }
9227              
9228 0 50       0 # \u \l \U \L \F \Q \E
9229 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9230             if ($right_e < $left_e) {
9231             $char[$i] = '\\' . $char[$i];
9232             }
9233 0         0 }
9234 0         0 elsif ($char[$i] eq '\u') {
9235             $char[$i] = '@{[Ekps9566::ucfirst qq<';
9236             $left_e++;
9237 0         0 }
9238 0         0 elsif ($char[$i] eq '\l') {
9239             $char[$i] = '@{[Ekps9566::lcfirst qq<';
9240             $left_e++;
9241 0         0 }
9242 1         2 elsif ($char[$i] eq '\U') {
9243             $char[$i] = '@{[Ekps9566::uc qq<';
9244             $left_e++;
9245 1         3 }
9246 1         2 elsif ($char[$i] eq '\L') {
9247             $char[$i] = '@{[Ekps9566::lc qq<';
9248             $left_e++;
9249 1         3 }
9250 9         16 elsif ($char[$i] eq '\F') {
9251             $char[$i] = '@{[Ekps9566::fc qq<';
9252             $left_e++;
9253 9         23 }
9254 22         44 elsif ($char[$i] eq '\Q') {
9255             $char[$i] = '@{[CORE::quotemeta qq<';
9256             $left_e++;
9257 22 50       60 }
9258 33         91 elsif ($char[$i] eq '\E') {
9259 33         53 if ($right_e < $left_e) {
9260             $char[$i] = '>]}';
9261             $right_e++;
9262 33         78 }
9263             else {
9264             $char[$i] = '';
9265             }
9266 0         0 }
9267 0 0       0 elsif ($char[$i] eq '\Q') {
9268 0         0 while (1) {
9269             if (++$i > $#char) {
9270 0 0       0 last;
9271 0         0 }
9272             if ($char[$i] eq '\E') {
9273             last;
9274             }
9275             }
9276             }
9277             elsif ($char[$i] eq '\E') {
9278             }
9279              
9280 0 0       0 # $0 --> $0
9281 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9282             if ($ignorecase) {
9283             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9284             }
9285 0 0       0 }
9286 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9287             if ($ignorecase) {
9288             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9289             }
9290             }
9291              
9292             # $$ --> $$
9293             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9294             }
9295              
9296             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9297 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9298 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9299 0         0 $char[$i] = e_capture($1);
9300             if ($ignorecase) {
9301             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9302             }
9303 0         0 }
9304 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9305 0         0 $char[$i] = e_capture($1);
9306             if ($ignorecase) {
9307             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9308             }
9309             }
9310              
9311 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
9312 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
9313 0         0 $char[$i] = e_capture($1.'->'.$2);
9314             if ($ignorecase) {
9315             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9316             }
9317             }
9318              
9319 0         0 # $$foo{ ... } --> $ $foo->{ ... }
9320 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
9321 0         0 $char[$i] = e_capture($1.'->'.$2);
9322             if ($ignorecase) {
9323             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9324             }
9325             }
9326              
9327 0         0 # $$foo
9328 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
9329 0         0 $char[$i] = e_capture($1);
9330             if ($ignorecase) {
9331             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9332             }
9333             }
9334              
9335 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ekps9566::PREMATCH()
9336 8         23 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
9337             if ($ignorecase) {
9338             $char[$i] = '@{[Ekps9566::ignorecase(Ekps9566::PREMATCH())]}';
9339 0         0 }
9340             else {
9341             $char[$i] = '@{[Ekps9566::PREMATCH()]}';
9342             }
9343             }
9344              
9345 8 50       27 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ekps9566::MATCH()
9346 8         27 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
9347             if ($ignorecase) {
9348             $char[$i] = '@{[Ekps9566::ignorecase(Ekps9566::MATCH())]}';
9349 0         0 }
9350             else {
9351             $char[$i] = '@{[Ekps9566::MATCH()]}';
9352             }
9353             }
9354              
9355 8 50       25 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ekps9566::POSTMATCH()
9356 6         16 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
9357             if ($ignorecase) {
9358             $char[$i] = '@{[Ekps9566::ignorecase(Ekps9566::POSTMATCH())]}';
9359 0         0 }
9360             else {
9361             $char[$i] = '@{[Ekps9566::POSTMATCH()]}';
9362             }
9363             }
9364              
9365 6 0       19 # ${ foo }
9366 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
9367             if ($ignorecase) {
9368             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9369             }
9370             }
9371              
9372 0         0 # ${ ... }
9373 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
9374 0         0 $char[$i] = e_capture($1);
9375             if ($ignorecase) {
9376             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9377             }
9378             }
9379              
9380 0         0 # $scalar or @array
9381 31 100       132 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
9382 31         115 $char[$i] = e_string($char[$i]);
9383             if ($ignorecase) {
9384             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9385             }
9386             }
9387              
9388 4 100 66     17 # quote character before ? + * {
    50          
9389             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9390             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
9391 188         1418 }
9392 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9393 0         0 my $char = $char[$i-1];
9394             if ($char[$i] eq '{') {
9395             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
9396 0         0 }
9397             else {
9398             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
9399             }
9400 0         0 }
9401             else {
9402             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9403             }
9404             }
9405             }
9406 187         806  
9407 1585 50       3429 # make regexp string
9408 1585 0 0     3761 $modifier =~ tr/i//d;
9409 0         0 if ($left_e > $right_e) {
9410             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9411             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
9412 0         0 }
9413             else {
9414             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
9415 0 100 100     0 }
9416 1585         10833 }
9417             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9418             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
9419 94         775 }
9420             else {
9421             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9422             }
9423             }
9424              
9425             #
9426             # double quote stuff
9427 1491     540 0 13875 #
9428             sub qq_stuff {
9429             my($delimiter,$end_delimiter,$stuff) = @_;
9430 540 100       975  
9431 540         1303 # scalar variable or array variable
9432             if ($stuff =~ /\A [\$\@] /oxms) {
9433             return $stuff;
9434             }
9435 300         1094  
  240         664  
9436 280         753 # quote by delimiter
9437 240 50       666 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
9438 240 50       408 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9439 240 50       349 next if $char eq $delimiter;
9440 240         417 next if $char eq $end_delimiter;
9441             if (not $octet{$char}) {
9442             return join '', 'qq', $char, $stuff, $char;
9443 240         980 }
9444             }
9445             return join '', 'qq', '<', $stuff, '>';
9446             }
9447              
9448             #
9449             # escape regexp (m'', qr'', and m''b, qr''b)
9450 0     163 0 0 #
9451 163   100     734 sub e_qr_q {
9452             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9453 163         491 $modifier ||= '';
9454 163 50       270  
9455 163         446 $modifier =~ tr/p//d;
9456 0         0 if ($modifier =~ /([adlu])/oxms) {
9457 0 0       0 my $line = 0;
9458 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9459 0         0 if ($filename ne __FILE__) {
9460             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9461             last;
9462 0         0 }
9463             }
9464             die qq{Unsupported modifier "$1" used at line $line.\n};
9465 0         0 }
9466              
9467             $slash = 'div';
9468 163 100       238  
    100          
9469 163         362 # literal null string pattern
9470 8         12 if ($string eq '') {
9471 8         41 $modifier =~ tr/bB//d;
9472             $modifier =~ tr/i//d;
9473             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9474             }
9475              
9476 8         43 # with /b /B modifier
9477             elsif ($modifier =~ tr/bB//d) {
9478             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
9479             }
9480              
9481 89         255 # without /b /B modifier
9482             else {
9483             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
9484             }
9485             }
9486              
9487             #
9488             # escape regexp (m'', qr'')
9489 66     66 0 144 #
9490             sub e_qr_qt {
9491 66 100       176 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9492              
9493             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9494 66         179  
9495             # split regexp
9496             my @char = $string =~ /\G((?>
9497             [^\x81-\xFE\\\[\$\@\/] |
9498             [\x81-\xFE][\x00-\xFF] |
9499             \[\^ |
9500             \[\: (?>[a-z]+) \:\] |
9501             \[\:\^ (?>[a-z]+) \:\] |
9502             [\$\@\/] |
9503             \\ (?:$q_char) |
9504             (?:$q_char)
9505             ))/oxmsg;
9506 66         724  
9507 66 100 100     247 # unescape character
    50 100        
    50 66        
    50          
    50          
    100          
    50          
9508             for (my $i=0; $i <= $#char; $i++) {
9509             if (0) {
9510             }
9511 79         839  
9512 0         0 # escape last octet of multiple-octet
9513             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9514             $char[$i] = $1 . '\\' . $2;
9515             }
9516              
9517 2         14 # open character class [...]
9518 0 0       0 elsif ($char[$i] eq '[') {
9519 0         0 my $left = $i;
9520             if ($char[$i+1] eq ']') {
9521 0         0 $i++;
9522 0 0       0 }
9523 0         0 while (1) {
9524             if (++$i > $#char) {
9525 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9526 0         0 }
9527             if ($char[$i] eq ']') {
9528             my $right = $i;
9529 0         0  
9530             # [...]
9531 0         0 splice @char, $left, $right-$left+1, Ekps9566::charlist_qr(@char[$left+1..$right-1], $modifier);
9532 0         0  
9533             $i = $left;
9534             last;
9535             }
9536             }
9537             }
9538              
9539 0         0 # open character class [^...]
9540 0 0       0 elsif ($char[$i] eq '[^') {
9541 0         0 my $left = $i;
9542             if ($char[$i+1] eq ']') {
9543 0         0 $i++;
9544 0 0       0 }
9545 0         0 while (1) {
9546             if (++$i > $#char) {
9547 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9548 0         0 }
9549             if ($char[$i] eq ']') {
9550             my $right = $i;
9551 0         0  
9552             # [^...]
9553 0         0 splice @char, $left, $right-$left+1, Ekps9566::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9554 0         0  
9555             $i = $left;
9556             last;
9557             }
9558             }
9559             }
9560              
9561 0         0 # escape $ @ / and \
9562             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9563             $char[$i] = '\\' . $char[$i];
9564             }
9565              
9566 0         0 # rewrite character class or escape character
9567             elsif (my $char = character_class($char[$i],$modifier)) {
9568             $char[$i] = $char;
9569             }
9570              
9571 0 50       0 # /i modifier
9572 16         41 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ekps9566::uc($char[$i]) ne Ekps9566::fc($char[$i]))) {
9573             if (CORE::length(Ekps9566::fc($char[$i])) == 1) {
9574             $char[$i] = '[' . Ekps9566::uc($char[$i]) . Ekps9566::fc($char[$i]) . ']';
9575 16         41 }
9576             else {
9577             $char[$i] = '(?:' . Ekps9566::uc($char[$i]) . '|' . Ekps9566::fc($char[$i]) . ')';
9578             }
9579             }
9580              
9581 0 0       0 # quote character before ? + * {
9582             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9583             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
9584 0         0 }
9585             else {
9586             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9587             }
9588             }
9589 0         0 }
9590 66         136  
9591             $delimiter = '/';
9592 66         113 $end_delimiter = '/';
9593 66         99  
9594             $modifier =~ tr/i//d;
9595             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9596             }
9597              
9598             #
9599             # escape regexp (m''b, qr''b)
9600 66     89 0 416 #
9601             sub e_qr_qb {
9602             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9603 89         291  
9604             # split regexp
9605             my @char = $string =~ /\G ((?>[^\\]|\\\\|[\x00-\xFF])) /oxmsg;
9606 89         343  
9607 89 50       248 # unescape character
    50          
9608             for (my $i=0; $i <= $#char; $i++) {
9609             if (0) {
9610             }
9611 199         635  
9612             # remain \\
9613             elsif ($char[$i] eq '\\\\') {
9614             }
9615              
9616 0         0 # escape $ @ / and \
9617             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9618             $char[$i] = '\\' . $char[$i];
9619             }
9620 0         0 }
9621 89         140  
9622 89         127 $delimiter = '/';
9623             $end_delimiter = '/';
9624             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9625             }
9626              
9627             #
9628             # escape regexp (s/here//)
9629 89     194 0 508 #
9630 194   100     561 sub e_s1 {
9631             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9632 194         870 $modifier ||= '';
9633 194 50       336  
9634 194         694 $modifier =~ tr/p//d;
9635 0         0 if ($modifier =~ /([adlu])/oxms) {
9636 0 0       0 my $line = 0;
9637 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9638 0         0 if ($filename ne __FILE__) {
9639             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9640             last;
9641 0         0 }
9642             }
9643             die qq{Unsupported modifier "$1" used at line $line.\n};
9644 0         0 }
9645              
9646             $slash = 'div';
9647 194 100       411  
    100          
9648 194         712 # literal null string pattern
9649 8         9 if ($string eq '') {
9650 8         11 $modifier =~ tr/bB//d;
9651             $modifier =~ tr/i//d;
9652             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9653             }
9654              
9655             # /b /B modifier
9656             elsif ($modifier =~ tr/bB//d) {
9657 8 50       58  
9658 44         100 # choice again delimiter
9659 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
9660 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
9661 0         0 my %octet = map {$_ => 1} @char;
9662 0         0 if (not $octet{')'}) {
9663             $delimiter = '(';
9664             $end_delimiter = ')';
9665 0         0 }
9666 0         0 elsif (not $octet{'}'}) {
9667             $delimiter = '{';
9668             $end_delimiter = '}';
9669 0         0 }
9670 0         0 elsif (not $octet{']'}) {
9671             $delimiter = '[';
9672             $end_delimiter = ']';
9673 0         0 }
9674 0         0 elsif (not $octet{'>'}) {
9675             $delimiter = '<';
9676             $end_delimiter = '>';
9677 0         0 }
9678 0 0       0 else {
9679 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9680 0         0 if (not $octet{$char}) {
9681 0         0 $delimiter = $char;
9682             $end_delimiter = $char;
9683             last;
9684             }
9685             }
9686             }
9687 0         0 }
9688 44         68  
9689 44         427 my $prematch = '';
9690             $prematch = q{(\G[\x00-\xFF]*?)};
9691             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9692 44 100       295 }
9693 142         486  
9694             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9695             my $metachar = qr/[\@\\|[\]{^]/oxms;
9696 142         565  
9697             # split regexp
9698             my @char = $string =~ /\G((?>
9699             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
9700             \\ (?>[1-9][0-9]*) |
9701             \\g (?>\s*) (?>[1-9][0-9]*) |
9702             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9703             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9704             \\x (?>[0-9A-Fa-f]{1,2}) |
9705             \\ (?>[0-7]{2,3}) |
9706             \\c [\x40-\x5F] |
9707             \\x\{ (?>[0-9A-Fa-f]+) \} |
9708             \\o\{ (?>[0-7]+) \} |
9709             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9710             \\ $q_char |
9711             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9712             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9713             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9714             [\$\@] $qq_variable |
9715             \$ (?>\s* [0-9]+) |
9716             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9717             \$ \$ (?![\w\{]) |
9718             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9719             \[\^ |
9720             \[\: (?>[a-z]+) :\] |
9721             \[\:\^ (?>[a-z]+) :\] |
9722             \(\? |
9723             $q_char
9724             ))/oxmsg;
9725 142 50       40298  
9726 142         1284 # choice again delimiter
  0         0  
9727 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9728 0         0 my %octet = map {$_ => 1} @char;
9729 0         0 if (not $octet{')'}) {
9730             $delimiter = '(';
9731             $end_delimiter = ')';
9732 0         0 }
9733 0         0 elsif (not $octet{'}'}) {
9734             $delimiter = '{';
9735             $end_delimiter = '}';
9736 0         0 }
9737 0         0 elsif (not $octet{']'}) {
9738             $delimiter = '[';
9739             $end_delimiter = ']';
9740 0         0 }
9741 0         0 elsif (not $octet{'>'}) {
9742             $delimiter = '<';
9743             $end_delimiter = '>';
9744 0         0 }
9745 0 0       0 else {
9746 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9747 0         0 if (not $octet{$char}) {
9748 0         0 $delimiter = $char;
9749             $end_delimiter = $char;
9750             last;
9751             }
9752             }
9753             }
9754             }
9755 0         0  
  142         307  
9756             # count '('
9757 476         885 my $parens = grep { $_ eq '(' } @char;
9758 142         238  
9759 142         240 my $left_e = 0;
9760             my $right_e = 0;
9761             for (my $i=0; $i <= $#char; $i++) {
9762 142 50 33     464  
    50 33        
    100          
    100          
    50          
    50          
9763 397         23747 # "\L\u" --> "\u\L"
9764             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9765             @char[$i,$i+1] = @char[$i+1,$i];
9766             }
9767              
9768 0         0 # "\U\l" --> "\l\U"
9769             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9770             @char[$i,$i+1] = @char[$i+1,$i];
9771             }
9772              
9773 0         0 # octal escape sequence
9774             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9775             $char[$i] = Ekps9566::octchr($1);
9776             }
9777              
9778 1         3 # hexadecimal escape sequence
9779             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9780             $char[$i] = Ekps9566::hexchr($1);
9781             }
9782              
9783             # \b{...} --> b\{...}
9784             # \B{...} --> B\{...}
9785             # \N{CHARNAME} --> N\{CHARNAME}
9786             # \p{PROPERTY} --> p\{PROPERTY}
9787 1         4 # \P{PROPERTY} --> P\{PROPERTY}
9788             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9789             $char[$i] = $1 . '\\' . $2;
9790             }
9791              
9792 0         0 # \p, \P, \X --> p, P, X
9793             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9794             $char[$i] = $1;
9795 0 100 100     0 }
    50 100        
    100 100        
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
9796              
9797             if (0) {
9798             }
9799 397         5083  
9800 0         0 # escape last octet of multiple-octet
9801             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9802             $char[$i] = $1 . '\\' . $2;
9803             }
9804              
9805 23 0 0     118 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
9806 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9807             if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
9808             $char[$i] .= join '', splice @char, $i+1, 3;
9809 0         0 }
9810             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
9811             $char[$i] .= join '', splice @char, $i+1, 2;
9812 0         0 }
9813             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
9814             $char[$i] .= join '', splice @char, $i+1, 1;
9815             }
9816             }
9817              
9818 0         0 # open character class [...]
9819 20 50       96 elsif ($char[$i] eq '[') {
9820 20         71 my $left = $i;
9821             if ($char[$i+1] eq ']') {
9822 0         0 $i++;
9823 20 50       31 }
9824 79         483 while (1) {
9825             if (++$i > $#char) {
9826 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9827 79         228 }
9828             if ($char[$i] eq ']') {
9829             my $right = $i;
9830 20 50       41  
9831 20         154 # [...]
  0         0  
9832             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9833             splice @char, $left, $right-$left+1, sprintf(q{@{[Ekps9566::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9834 0         0 }
9835             else {
9836             splice @char, $left, $right-$left+1, Ekps9566::charlist_qr(@char[$left+1..$right-1], $modifier);
9837 20         121 }
9838 20         37  
9839             $i = $left;
9840             last;
9841             }
9842             }
9843             }
9844              
9845 20         67 # open character class [^...]
9846 0 0       0 elsif ($char[$i] eq '[^') {
9847 0         0 my $left = $i;
9848             if ($char[$i+1] eq ']') {
9849 0         0 $i++;
9850 0 0       0 }
9851 0         0 while (1) {
9852             if (++$i > $#char) {
9853 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9854 0         0 }
9855             if ($char[$i] eq ']') {
9856             my $right = $i;
9857 0 0       0  
9858 0         0 # [^...]
  0         0  
9859             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9860             splice @char, $left, $right-$left+1, sprintf(q{@{[Ekps9566::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9861 0         0 }
9862             else {
9863             splice @char, $left, $right-$left+1, Ekps9566::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9864 0         0 }
9865 0         0  
9866             $i = $left;
9867             last;
9868             }
9869             }
9870             }
9871              
9872 0         0 # rewrite character class or escape character
9873             elsif (my $char = character_class($char[$i],$modifier)) {
9874             $char[$i] = $char;
9875             }
9876              
9877 11 50       30 # /i modifier
9878 11         26 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ekps9566::uc($char[$i]) ne Ekps9566::fc($char[$i]))) {
9879             if (CORE::length(Ekps9566::fc($char[$i])) == 1) {
9880             $char[$i] = '[' . Ekps9566::uc($char[$i]) . Ekps9566::fc($char[$i]) . ']';
9881 11         26 }
9882             else {
9883             $char[$i] = '(?:' . Ekps9566::uc($char[$i]) . '|' . Ekps9566::fc($char[$i]) . ')';
9884             }
9885             }
9886              
9887 0 50       0 # \u \l \U \L \F \Q \E
9888 8         26 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9889             if ($right_e < $left_e) {
9890             $char[$i] = '\\' . $char[$i];
9891             }
9892 0         0 }
9893 0         0 elsif ($char[$i] eq '\u') {
9894             $char[$i] = '@{[Ekps9566::ucfirst qq<';
9895             $left_e++;
9896 0         0 }
9897 0         0 elsif ($char[$i] eq '\l') {
9898             $char[$i] = '@{[Ekps9566::lcfirst qq<';
9899             $left_e++;
9900 0         0 }
9901 0         0 elsif ($char[$i] eq '\U') {
9902             $char[$i] = '@{[Ekps9566::uc qq<';
9903             $left_e++;
9904 0         0 }
9905 0         0 elsif ($char[$i] eq '\L') {
9906             $char[$i] = '@{[Ekps9566::lc qq<';
9907             $left_e++;
9908 0         0 }
9909 0         0 elsif ($char[$i] eq '\F') {
9910             $char[$i] = '@{[Ekps9566::fc qq<';
9911             $left_e++;
9912 0         0 }
9913 7         13 elsif ($char[$i] eq '\Q') {
9914             $char[$i] = '@{[CORE::quotemeta qq<';
9915             $left_e++;
9916 7 50       24 }
9917 7         18 elsif ($char[$i] eq '\E') {
9918 7         12 if ($right_e < $left_e) {
9919             $char[$i] = '>]}';
9920             $right_e++;
9921 7         16 }
9922             else {
9923             $char[$i] = '';
9924             }
9925 0         0 }
9926 0 0       0 elsif ($char[$i] eq '\Q') {
9927 0         0 while (1) {
9928             if (++$i > $#char) {
9929 0 0       0 last;
9930 0         0 }
9931             if ($char[$i] eq '\E') {
9932             last;
9933             }
9934             }
9935             }
9936             elsif ($char[$i] eq '\E') {
9937             }
9938              
9939             # \0 --> \0
9940             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
9941             }
9942              
9943             # \g{N}, \g{-N}
9944              
9945             # P.108 Using Simple Patterns
9946             # in Chapter 7: In the World of Regular Expressions
9947             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
9948              
9949             # P.221 Capturing
9950             # in Chapter 5: Pattern Matching
9951             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
9952              
9953             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
9954             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9955             }
9956              
9957 0 0       0 # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
9958 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9959             if ($1 <= $parens) {
9960             $char[$i] = '\\g{' . ($1 + 1) . '}';
9961             }
9962             }
9963              
9964 0 0       0 # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
9965 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9966             if ($1 <= $parens) {
9967             $char[$i] = '\\g' . ($1 + 1);
9968             }
9969             }
9970              
9971 0 0       0 # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
9972 0         0 elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9973             if ($1 <= $parens) {
9974             $char[$i] = '\\' . ($1 + 1);
9975             }
9976             }
9977              
9978 0 0       0 # $0 --> $0
9979 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9980             if ($ignorecase) {
9981             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9982             }
9983 0 0       0 }
9984 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9985             if ($ignorecase) {
9986             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
9987             }
9988             }
9989              
9990             # $$ --> $$
9991             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9992             }
9993              
9994             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9995 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9996 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9997 0         0 $char[$i] = e_capture($1);
9998             if ($ignorecase) {
9999             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10000             }
10001 0         0 }
10002 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10003 0         0 $char[$i] = e_capture($1);
10004             if ($ignorecase) {
10005             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10006             }
10007             }
10008              
10009 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10010 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
10011 0         0 $char[$i] = e_capture($1.'->'.$2);
10012             if ($ignorecase) {
10013             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10014             }
10015             }
10016              
10017 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10018 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
10019 0         0 $char[$i] = e_capture($1.'->'.$2);
10020             if ($ignorecase) {
10021             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10022             }
10023             }
10024              
10025 0         0 # $$foo
10026 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10027 0         0 $char[$i] = e_capture($1);
10028             if ($ignorecase) {
10029             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10030             }
10031             }
10032              
10033 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ekps9566::PREMATCH()
10034 4         17 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10035             if ($ignorecase) {
10036             $char[$i] = '@{[Ekps9566::ignorecase(Ekps9566::PREMATCH())]}';
10037 0         0 }
10038             else {
10039             $char[$i] = '@{[Ekps9566::PREMATCH()]}';
10040             }
10041             }
10042              
10043 4 50       17 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ekps9566::MATCH()
10044 4         17 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10045             if ($ignorecase) {
10046             $char[$i] = '@{[Ekps9566::ignorecase(Ekps9566::MATCH())]}';
10047 0         0 }
10048             else {
10049             $char[$i] = '@{[Ekps9566::MATCH()]}';
10050             }
10051             }
10052              
10053 4 50       17 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ekps9566::POSTMATCH()
10054 3         13 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10055             if ($ignorecase) {
10056             $char[$i] = '@{[Ekps9566::ignorecase(Ekps9566::POSTMATCH())]}';
10057 0         0 }
10058             else {
10059             $char[$i] = '@{[Ekps9566::POSTMATCH()]}';
10060             }
10061             }
10062              
10063 3 0       11 # ${ foo }
10064 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
10065             if ($ignorecase) {
10066             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10067             }
10068             }
10069              
10070 0         0 # ${ ... }
10071 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10072 0         0 $char[$i] = e_capture($1);
10073             if ($ignorecase) {
10074             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10075             }
10076             }
10077              
10078 0         0 # $scalar or @array
10079 13 50       43 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10080 13         57 $char[$i] = e_string($char[$i]);
10081             if ($ignorecase) {
10082             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10083             }
10084             }
10085              
10086 0 50       0 # quote character before ? + * {
10087             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10088             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10089 23         147 }
10090             else {
10091             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10092             }
10093             }
10094             }
10095 23         121  
10096 142         370 # make regexp string
10097 142         377 my $prematch = '';
10098 142 50       259 $prematch = "($anchor)";
10099 142         363 $modifier =~ tr/i//d;
10100             if ($left_e > $right_e) {
10101 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
10102             }
10103             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10104             }
10105              
10106             #
10107             # escape regexp (s'here'' or s'here''b)
10108 142     96 0 10253 #
10109 96   100     213 sub e_s1_q {
10110             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10111 96         213 $modifier ||= '';
10112 96 50       122  
10113 96         304 $modifier =~ tr/p//d;
10114 0         0 if ($modifier =~ /([adlu])/oxms) {
10115 0 0       0 my $line = 0;
10116 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10117 0         0 if ($filename ne __FILE__) {
10118             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10119             last;
10120 0         0 }
10121             }
10122             die qq{Unsupported modifier "$1" used at line $line.\n};
10123 0         0 }
10124              
10125             $slash = 'div';
10126 96 100       134  
    100          
10127 96         211 # literal null string pattern
10128 8         12 if ($string eq '') {
10129 8         9 $modifier =~ tr/bB//d;
10130             $modifier =~ tr/i//d;
10131             return join '', $ope, $delimiter, $end_delimiter, $modifier;
10132             }
10133              
10134 8         58 # with /b /B modifier
10135             elsif ($modifier =~ tr/bB//d) {
10136             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
10137             }
10138              
10139 44         91 # without /b /B modifier
10140             else {
10141             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
10142             }
10143             }
10144              
10145             #
10146             # escape regexp (s'here'')
10147 44     44 0 91 #
10148             sub e_s1_qt {
10149 44 100       94 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10150              
10151             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10152 44         88  
10153             # split regexp
10154             my @char = $string =~ /\G((?>
10155             [^\x81-\xFE\\\[\$\@\/] |
10156             [\x81-\xFE][\x00-\xFF] |
10157             \[\^ |
10158             \[\: (?>[a-z]+) \:\] |
10159             \[\:\^ (?>[a-z]+) \:\] |
10160             [\$\@\/] |
10161             \\ (?:$q_char) |
10162             (?:$q_char)
10163             ))/oxmsg;
10164 44         459  
10165 44 50 100     124 # unescape character
    50 100        
    50 66        
    50          
    100          
    100          
    50          
10166             for (my $i=0; $i <= $#char; $i++) {
10167             if (0) {
10168             }
10169 62         541  
10170 0         0 # escape last octet of multiple-octet
10171             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10172             $char[$i] = $1 . '\\' . $2;
10173             }
10174              
10175 0         0 # open character class [...]
10176 0 0       0 elsif ($char[$i] eq '[') {
10177 0         0 my $left = $i;
10178             if ($char[$i+1] eq ']') {
10179 0         0 $i++;
10180 0 0       0 }
10181 0         0 while (1) {
10182             if (++$i > $#char) {
10183 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10184 0         0 }
10185             if ($char[$i] eq ']') {
10186             my $right = $i;
10187 0         0  
10188             # [...]
10189 0         0 splice @char, $left, $right-$left+1, Ekps9566::charlist_qr(@char[$left+1..$right-1], $modifier);
10190 0         0  
10191             $i = $left;
10192             last;
10193             }
10194             }
10195             }
10196              
10197 0         0 # open character class [^...]
10198 0 0       0 elsif ($char[$i] eq '[^') {
10199 0         0 my $left = $i;
10200             if ($char[$i+1] eq ']') {
10201 0         0 $i++;
10202 0 0       0 }
10203 0         0 while (1) {
10204             if (++$i > $#char) {
10205 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10206 0         0 }
10207             if ($char[$i] eq ']') {
10208             my $right = $i;
10209 0         0  
10210             # [^...]
10211 0         0 splice @char, $left, $right-$left+1, Ekps9566::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10212 0         0  
10213             $i = $left;
10214             last;
10215             }
10216             }
10217             }
10218              
10219 0         0 # escape $ @ / and \
10220             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10221             $char[$i] = '\\' . $char[$i];
10222             }
10223              
10224 0         0 # rewrite character class or escape character
10225             elsif (my $char = character_class($char[$i],$modifier)) {
10226             $char[$i] = $char;
10227             }
10228              
10229 6 50       14 # /i modifier
10230 8         17 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ekps9566::uc($char[$i]) ne Ekps9566::fc($char[$i]))) {
10231             if (CORE::length(Ekps9566::fc($char[$i])) == 1) {
10232             $char[$i] = '[' . Ekps9566::uc($char[$i]) . Ekps9566::fc($char[$i]) . ']';
10233 8         15 }
10234             else {
10235             $char[$i] = '(?:' . Ekps9566::uc($char[$i]) . '|' . Ekps9566::fc($char[$i]) . ')';
10236             }
10237             }
10238              
10239 0 0       0 # quote character before ? + * {
10240             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10241             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
10242 0         0 }
10243             else {
10244             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10245             }
10246             }
10247 0         0 }
10248 44         77  
10249 44         68 $modifier =~ tr/i//d;
10250 44         54 $delimiter = '/';
10251 44         51 $end_delimiter = '/';
10252 44         92 my $prematch = '';
10253             $prematch = "($anchor)";
10254             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10255             }
10256              
10257             #
10258             # escape regexp (s'here''b)
10259 44     44 0 313 #
10260             sub e_s1_qb {
10261             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10262 44         92  
10263             # split regexp
10264             my @char = $string =~ /\G (?>[^\\]|\\\\|[\x00-\xFF]) /oxmsg;
10265 44         150  
10266 44 50       105 # unescape character
    50          
10267             for (my $i=0; $i <= $#char; $i++) {
10268             if (0) {
10269             }
10270 98         288  
10271             # remain \\
10272             elsif ($char[$i] eq '\\\\') {
10273             }
10274              
10275 0         0 # escape $ @ / and \
10276             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10277             $char[$i] = '\\' . $char[$i];
10278             }
10279 0         0 }
10280 44         75  
10281 44         53 $delimiter = '/';
10282 44         67 $end_delimiter = '/';
10283 44         46 my $prematch = '';
10284             $prematch = q{(\G[\x00-\xFF]*?)};
10285             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10286             }
10287              
10288             #
10289             # escape regexp (s''here')
10290 44     91 0 290 #
10291             sub e_s2_q {
10292 91         171 my($ope,$delimiter,$end_delimiter,$string) = @_;
10293              
10294 91         115 $slash = 'div';
10295 91         14750  
10296 91 50 66     242 my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\\\|$q_char) /oxmsg;
    50 33        
    100          
    100          
10297             for (my $i=0; $i <= $#char; $i++) {
10298             if (0) {
10299             }
10300 9         109  
10301 0         0 # escape last octet of multiple-octet
10302             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10303             $char[$i] = $1 . '\\' . $2;
10304 0         0 }
10305             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10306             $char[$i] = $1 . '\\' . $2;
10307             }
10308              
10309             # not escape \\
10310             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
10311             }
10312              
10313 0         0 # escape $ @ / and \
10314             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10315             $char[$i] = '\\' . $char[$i];
10316 5 50 66     127 }
10317 91         240 }
10318             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10319             $char[-1] = $1 . '\\' . $2;
10320 0         0 }
10321              
10322             return join '', $ope, $delimiter, @char, $end_delimiter;
10323             }
10324              
10325             #
10326             # escape regexp (s/here/and here/modifier)
10327 91     290 0 333 #
10328 290   100     2145 sub e_sub {
10329             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
10330 290         1187 $modifier ||= '';
10331 290 50       608  
10332 290         1122 $modifier =~ tr/p//d;
10333 0         0 if ($modifier =~ /([adlu])/oxms) {
10334 0 0       0 my $line = 0;
10335 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10336 0         0 if ($filename ne __FILE__) {
10337             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10338             last;
10339 0         0 }
10340             }
10341             die qq{Unsupported modifier "$1" used at line $line.\n};
10342 0 100       0 }
10343 290         698  
10344 37         49 if ($variable eq '') {
10345             $variable = '$_';
10346             $bind_operator = ' =~ ';
10347 37         55 }
10348              
10349             $slash = 'div';
10350              
10351             # P.128 Start of match (or end of previous match): \G
10352             # P.130 Advanced Use of \G with Perl
10353             # in Chapter 3: Overview of Regular Expression Features and Flavors
10354             # P.312 Iterative Matching: Scalar Context, with /g
10355             # in Chapter 7: Perl
10356             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
10357              
10358             # P.181 Where You Left Off: The \G Assertion
10359             # in Chapter 5: Pattern Matching
10360             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10361              
10362             # P.220 Where You Left Off: The \G Assertion
10363             # in Chapter 5: Pattern Matching
10364 290         448 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10365 290         436  
10366             my $e_modifier = $modifier =~ tr/e//d;
10367 290         401 my $r_modifier = $modifier =~ tr/r//d;
10368 290 50       438  
10369 290         786 my $my = '';
10370 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
10371 0         0 $my = $variable;
10372             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
10373             $variable =~ s/ = .+ \z//oxms;
10374 0         0 }
10375 290         701  
10376             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
10377             $variable_basename =~ s/ \s+ \z//oxms;
10378 290         515  
10379 290 100       404 # quote replacement string
10380 290         604 my $e_replacement = '';
10381 17         39 if ($e_modifier >= 1) {
10382             $e_replacement = e_qq('', '', '', $replacement);
10383             $e_modifier--;
10384 17 100       31 }
10385 273         848 else {
10386             if ($delimiter2 eq "'") {
10387             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
10388 91         156 }
10389             else {
10390             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
10391             }
10392 182         557 }
10393              
10394             my $sub = '';
10395 290 100       486  
10396 290 100       599 # with /r
    50          
10397             if ($r_modifier) {
10398             if (0) {
10399             }
10400 8         26  
10401 0 50       0 # s///gr with multibyte anchoring
10402             elsif ($modifier =~ /g/oxms) {
10403             $sub = sprintf(
10404             # 1 2 3 4 5
10405             q,
10406              
10407             $variable, # 1
10408             ($delimiter1 eq "'") ? # 2
10409             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10410             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10411             $s_matched, # 3
10412             $e_replacement, # 4
10413             '$Ekps9566::re_r=CORE::eval $Ekps9566::re_r; ' x $e_modifier, # 5
10414             );
10415             }
10416              
10417 4 0       25 # s///gr without multibyte anchoring
10418             elsif ($modifier =~ /g/oxms) {
10419             $sub = sprintf(
10420             # 1 2 3 4 5
10421             q,
10422              
10423             $variable, # 1
10424             ($delimiter1 eq "'") ? # 2
10425             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10426             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10427             $s_matched, # 3
10428             $e_replacement, # 4
10429             '$Ekps9566::re_r=CORE::eval $Ekps9566::re_r; ' x $e_modifier, # 5
10430             );
10431             }
10432              
10433             # s///r
10434 0         0 else {
10435 4         13  
10436             my $prematch = q{$`};
10437 4 50       6 $prematch = q{${1}};
10438              
10439             $sub = sprintf(
10440             # 1 2 3 4 5 6 7
10441             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Ekps9566::re_r=%s; %s"%s$Ekps9566::re_r$'" } : %s>,
10442              
10443             $variable, # 1
10444             ($delimiter1 eq "'") ? # 2
10445             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10446             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10447             $s_matched, # 3
10448             $e_replacement, # 4
10449             '$Ekps9566::re_r=CORE::eval $Ekps9566::re_r; ' x $e_modifier, # 5
10450             $prematch, # 6
10451             $variable, # 7
10452             );
10453             }
10454 4 50       22  
10455 8         80 # $var !~ s///r doesn't make sense
10456             if ($bind_operator =~ / !~ /oxms) {
10457             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
10458             }
10459             }
10460              
10461 0 100       0 # without /r
    50          
10462             else {
10463             if (0) {
10464             }
10465 282         992  
10466 0 100       0 # s///g with multibyte anchoring
    100          
10467             elsif ($modifier =~ /g/oxms) {
10468             $sub = sprintf(
10469             # 1 2 3 4 5 6 7 8 9 10
10470             q,
10471              
10472             $variable, # 1
10473             ($delimiter1 eq "'") ? # 2
10474             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10475             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10476             $s_matched, # 3
10477             $e_replacement, # 4
10478             '$Ekps9566::re_r=CORE::eval $Ekps9566::re_r; ' x $e_modifier, # 5
10479             $variable, # 6
10480             $variable, # 7
10481             $variable, # 8
10482             $variable, # 9
10483              
10484             # Binary "!~" is just like "=~" except the return value is negated in the logical sense.
10485             # It returns false if the match succeeds, and true if it fails.
10486             # (and so on)
10487              
10488             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 10
10489             );
10490             }
10491              
10492 35 0       154 # s///g without multibyte anchoring
    0          
10493             elsif ($modifier =~ /g/oxms) {
10494             $sub = sprintf(
10495             # 1 2 3 4 5 6 7 8
10496             q,
10497              
10498             $variable, # 1
10499             ($delimiter1 eq "'") ? # 2
10500             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10501             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10502             $s_matched, # 3
10503             $e_replacement, # 4
10504             '$Ekps9566::re_r=CORE::eval $Ekps9566::re_r; ' x $e_modifier, # 5
10505             $variable, # 6
10506             $variable, # 7
10507             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
10508             );
10509             }
10510              
10511             # s///
10512 0         0 else {
10513 247         456  
10514             my $prematch = q{$`};
10515 247 100       349 $prematch = q{${1}};
    100          
10516              
10517             $sub = sprintf(
10518              
10519             ($bind_operator =~ / =~ /oxms) ?
10520              
10521             # 1 2 3 4 5 6 7 8
10522             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Ekps9566::re_r=%s; %s%s="%s$Ekps9566::re_r$'"; 1 } : undef> :
10523              
10524             # 1 2 3 4 5 6 7 8
10525             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Ekps9566::re_r=%s; %s%s="%s$Ekps9566::re_r$'"; undef }>,
10526              
10527             $variable, # 1
10528             $bind_operator, # 2
10529             ($delimiter1 eq "'") ? # 3
10530             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10531             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10532             $s_matched, # 4
10533             $e_replacement, # 5
10534             '$Ekps9566::re_r=CORE::eval $Ekps9566::re_r; ' x $e_modifier, # 6
10535             $variable, # 7
10536             $prematch, # 8
10537             );
10538             }
10539             }
10540 247 50       1154  
10541 290         822 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
10542             if ($my ne '') {
10543             $sub = "($my, $sub)[1]";
10544             }
10545 0         0  
10546 290         412 # clear s/// variable
10547             $sub_variable = '';
10548 290         393 $bind_operator = '';
10549              
10550             return $sub;
10551             }
10552              
10553             #
10554             # escape chdir (qq//, "")
10555 290     0 0 2537 #
10556             sub e_chdir {
10557 0 0       0 my($ope,$delimiter,$end_delimiter,$string) = @_;
10558 0 0       0  
10559 0 0       0 if ($^W) {
10560 0         0 if (Ekps9566::_MSWin32_5Cended_path($string)) {
10561 0         0 if ($] !~ /^5\.005/oxms) {
10562             warn <
10563             @{[__FILE__]}: Can't chdir to '$string'
10564              
10565             chdir does not work with chr(0x5C) at end of path
10566             http://bugs.activestate.com/show_bug.cgi?id=81839
10567             END
10568             }
10569             }
10570 0         0 }
10571              
10572             return e_qq($ope,$delimiter,$end_delimiter,$string);
10573             }
10574              
10575             #
10576             # escape chdir (q//, '')
10577 0     2 0 0 #
10578             sub e_chdir_q {
10579 2 50       6 my($ope,$delimiter,$end_delimiter,$string) = @_;
10580 2 0       7  
10581 0 0       0 if ($^W) {
10582 0         0 if (Ekps9566::_MSWin32_5Cended_path($string)) {
10583 0         0 if ($] !~ /^5\.005/oxms) {
10584             warn <
10585             @{[__FILE__]}: Can't chdir to '$string'
10586              
10587             chdir does not work with chr(0x5C) at end of path
10588             http://bugs.activestate.com/show_bug.cgi?id=81839
10589             END
10590             }
10591             }
10592 0         0 }
10593              
10594             return e_q($ope,$delimiter,$end_delimiter,$string);
10595             }
10596              
10597             #
10598             # escape regexp of split qr//
10599 2     273 0 23 #
10600 273   100     1320 sub e_split {
10601             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10602 273         1332 $modifier ||= '';
10603 273 50       558  
10604 273         777 $modifier =~ tr/p//d;
10605 0         0 if ($modifier =~ /([adlu])/oxms) {
10606 0 0       0 my $line = 0;
10607 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10608 0         0 if ($filename ne __FILE__) {
10609             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10610             last;
10611 0         0 }
10612             }
10613             die qq{Unsupported modifier "$1" used at line $line.\n};
10614 0         0 }
10615              
10616             $slash = 'div';
10617 273 100       488  
10618 273         725 # /b /B modifier
10619             if ($modifier =~ tr/bB//d) {
10620             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10621 84 100       454 }
10622 189         702  
10623             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10624             my $metachar = qr/[\@\\|[\]{^]/oxms;
10625 189         724  
10626             # split regexp
10627             my @char = $string =~ /\G((?>
10628             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
10629             \\x (?>[0-9A-Fa-f]{1,2}) |
10630             \\ (?>[0-7]{2,3}) |
10631             \\c [\x40-\x5F] |
10632             \\x\{ (?>[0-9A-Fa-f]+) \} |
10633             \\o\{ (?>[0-7]+) \} |
10634             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
10635             \\ $q_char |
10636             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
10637             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
10638             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
10639             [\$\@] $qq_variable |
10640             \$ (?>\s* [0-9]+) |
10641             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
10642             \$ \$ (?![\w\{]) |
10643             \$ (?>\s*) \$ (?>\s*) $qq_variable |
10644             \[\^ |
10645             \[\: (?>[a-z]+) :\] |
10646             \[\:\^ (?>[a-z]+) :\] |
10647             \(\? |
10648             $q_char
10649 189         16550 ))/oxmsg;
10650 189         595  
10651 189         462 my $left_e = 0;
10652             my $right_e = 0;
10653             for (my $i=0; $i <= $#char; $i++) {
10654 189 50 33     558  
    50 33        
    100          
    100          
    50          
    50          
10655 372         2587 # "\L\u" --> "\u\L"
10656             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
10657             @char[$i,$i+1] = @char[$i+1,$i];
10658             }
10659              
10660 0         0 # "\U\l" --> "\l\U"
10661             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
10662             @char[$i,$i+1] = @char[$i+1,$i];
10663             }
10664              
10665 0         0 # octal escape sequence
10666             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
10667             $char[$i] = Ekps9566::octchr($1);
10668             }
10669              
10670 1         4 # hexadecimal escape sequence
10671             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
10672             $char[$i] = Ekps9566::hexchr($1);
10673             }
10674              
10675             # \b{...} --> b\{...}
10676             # \B{...} --> B\{...}
10677             # \N{CHARNAME} --> N\{CHARNAME}
10678             # \p{PROPERTY} --> p\{PROPERTY}
10679 1         3 # \P{PROPERTY} --> P\{PROPERTY}
10680             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
10681             $char[$i] = $1 . '\\' . $2;
10682             }
10683              
10684 0         0 # \p, \P, \X --> p, P, X
10685             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
10686             $char[$i] = $1;
10687 0 50 100     0 }
    50 100        
    100 66        
    100 100        
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
10688              
10689             if (0) {
10690             }
10691 372         3975  
10692 0         0 # escape last octet of multiple-octet
10693             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10694             $char[$i] = $1 . '\\' . $2;
10695             }
10696              
10697 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
10698 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
10699             if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
10700             $char[$i] .= join '', splice @char, $i+1, 3;
10701 0         0 }
10702             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
10703             $char[$i] .= join '', splice @char, $i+1, 2;
10704 0         0 }
10705             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
10706             $char[$i] .= join '', splice @char, $i+1, 1;
10707             }
10708             }
10709              
10710 0         0 # open character class [...]
10711 3 50       6 elsif ($char[$i] eq '[') {
10712 3         11 my $left = $i;
10713             if ($char[$i+1] eq ']') {
10714 0         0 $i++;
10715 3 50       4 }
10716 7         13 while (1) {
10717             if (++$i > $#char) {
10718 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10719 7         14 }
10720             if ($char[$i] eq ']') {
10721             my $right = $i;
10722 3 50       5  
10723 3         18 # [...]
  0         0  
10724             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10725             splice @char, $left, $right-$left+1, sprintf(q{@{[Ekps9566::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10726 0         0 }
10727             else {
10728             splice @char, $left, $right-$left+1, Ekps9566::charlist_qr(@char[$left+1..$right-1], $modifier);
10729 3         18 }
10730 3         6  
10731             $i = $left;
10732             last;
10733             }
10734             }
10735             }
10736              
10737 3         7 # open character class [^...]
10738 1 50       3 elsif ($char[$i] eq '[^') {
10739 1         4 my $left = $i;
10740             if ($char[$i+1] eq ']') {
10741 0         0 $i++;
10742 1 50       2 }
10743 2         5 while (1) {
10744             if (++$i > $#char) {
10745 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10746 2         5 }
10747             if ($char[$i] eq ']') {
10748             my $right = $i;
10749 1 50       2  
10750 1         7 # [^...]
  0         0  
10751             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10752             splice @char, $left, $right-$left+1, sprintf(q{@{[Ekps9566::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10753 0         0 }
10754             else {
10755             splice @char, $left, $right-$left+1, Ekps9566::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10756 1         19 }
10757 1         2  
10758             $i = $left;
10759             last;
10760             }
10761             }
10762             }
10763              
10764 1         3 # rewrite character class or escape character
10765             elsif (my $char = character_class($char[$i],$modifier)) {
10766             $char[$i] = $char;
10767             }
10768              
10769             # P.794 29.2.161. split
10770             # in Chapter 29: Functions
10771             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10772              
10773             # P.951 split
10774             # in Chapter 27: Functions
10775             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10776              
10777             # said "The //m modifier is assumed when you split on the pattern /^/",
10778             # but perl5.008 is not so. Therefore, this software adds //m.
10779             # (and so on)
10780              
10781 5         19 # split(m/^/) --> split(m/^/m)
10782             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
10783             $modifier .= 'm';
10784             }
10785              
10786 11 50       41 # /i modifier
10787 18         41 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ekps9566::uc($char[$i]) ne Ekps9566::fc($char[$i]))) {
10788             if (CORE::length(Ekps9566::fc($char[$i])) == 1) {
10789             $char[$i] = '[' . Ekps9566::uc($char[$i]) . Ekps9566::fc($char[$i]) . ']';
10790 18         48 }
10791             else {
10792             $char[$i] = '(?:' . Ekps9566::uc($char[$i]) . '|' . Ekps9566::fc($char[$i]) . ')';
10793             }
10794             }
10795              
10796 0 50       0 # \u \l \U \L \F \Q \E
10797 2         7 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
10798             if ($right_e < $left_e) {
10799             $char[$i] = '\\' . $char[$i];
10800             }
10801 0         0 }
10802 0         0 elsif ($char[$i] eq '\u') {
10803             $char[$i] = '@{[Ekps9566::ucfirst qq<';
10804             $left_e++;
10805 0         0 }
10806 0         0 elsif ($char[$i] eq '\l') {
10807             $char[$i] = '@{[Ekps9566::lcfirst qq<';
10808             $left_e++;
10809 0         0 }
10810 0         0 elsif ($char[$i] eq '\U') {
10811             $char[$i] = '@{[Ekps9566::uc qq<';
10812             $left_e++;
10813 0         0 }
10814 0         0 elsif ($char[$i] eq '\L') {
10815             $char[$i] = '@{[Ekps9566::lc qq<';
10816             $left_e++;
10817 0         0 }
10818 0         0 elsif ($char[$i] eq '\F') {
10819             $char[$i] = '@{[Ekps9566::fc qq<';
10820             $left_e++;
10821 0         0 }
10822 0         0 elsif ($char[$i] eq '\Q') {
10823             $char[$i] = '@{[CORE::quotemeta qq<';
10824             $left_e++;
10825 0 0       0 }
10826 0         0 elsif ($char[$i] eq '\E') {
10827 0         0 if ($right_e < $left_e) {
10828             $char[$i] = '>]}';
10829             $right_e++;
10830 0         0 }
10831             else {
10832             $char[$i] = '';
10833             }
10834 0         0 }
10835 0 0       0 elsif ($char[$i] eq '\Q') {
10836 0         0 while (1) {
10837             if (++$i > $#char) {
10838 0 0       0 last;
10839 0         0 }
10840             if ($char[$i] eq '\E') {
10841             last;
10842             }
10843             }
10844             }
10845             elsif ($char[$i] eq '\E') {
10846             }
10847              
10848 0 0       0 # $0 --> $0
10849 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
10850             if ($ignorecase) {
10851             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10852             }
10853 0 0       0 }
10854 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
10855             if ($ignorecase) {
10856             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10857             }
10858             }
10859              
10860             # $$ --> $$
10861             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10862             }
10863              
10864             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10865 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
10866 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10867 0         0 $char[$i] = e_capture($1);
10868             if ($ignorecase) {
10869             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10870             }
10871 0         0 }
10872 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10873 0         0 $char[$i] = e_capture($1);
10874             if ($ignorecase) {
10875             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10876             }
10877             }
10878              
10879 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10880 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
10881 0         0 $char[$i] = e_capture($1.'->'.$2);
10882             if ($ignorecase) {
10883             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10884             }
10885             }
10886              
10887 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10888 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
10889 0         0 $char[$i] = e_capture($1.'->'.$2);
10890             if ($ignorecase) {
10891             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10892             }
10893             }
10894              
10895 0         0 # $$foo
10896 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10897 0         0 $char[$i] = e_capture($1);
10898             if ($ignorecase) {
10899             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10900             }
10901             }
10902              
10903 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ekps9566::PREMATCH()
10904 12         45 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10905             if ($ignorecase) {
10906             $char[$i] = '@{[Ekps9566::ignorecase(Ekps9566::PREMATCH())]}';
10907 0         0 }
10908             else {
10909             $char[$i] = '@{[Ekps9566::PREMATCH()]}';
10910             }
10911             }
10912              
10913 12 50       61 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ekps9566::MATCH()
10914 12         37 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10915             if ($ignorecase) {
10916             $char[$i] = '@{[Ekps9566::ignorecase(Ekps9566::MATCH())]}';
10917 0         0 }
10918             else {
10919             $char[$i] = '@{[Ekps9566::MATCH()]}';
10920             }
10921             }
10922              
10923 12 50       64 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ekps9566::POSTMATCH()
10924 9         24 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10925             if ($ignorecase) {
10926             $char[$i] = '@{[Ekps9566::ignorecase(Ekps9566::POSTMATCH())]}';
10927 0         0 }
10928             else {
10929             $char[$i] = '@{[Ekps9566::POSTMATCH()]}';
10930             }
10931             }
10932              
10933 9 0       46 # ${ foo }
10934 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
10935             if ($ignorecase) {
10936             $char[$i] = '@{[Ekps9566::ignorecase(' . $1 . ')]}';
10937             }
10938             }
10939              
10940 0         0 # ${ ... }
10941 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10942 0         0 $char[$i] = e_capture($1);
10943             if ($ignorecase) {
10944             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10945             }
10946             }
10947              
10948 0         0 # $scalar or @array
10949 3 50       10 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10950 3         15 $char[$i] = e_string($char[$i]);
10951             if ($ignorecase) {
10952             $char[$i] = '@{[Ekps9566::ignorecase(' . $char[$i] . ')]}';
10953             }
10954             }
10955              
10956 0 100       0 # quote character before ? + * {
10957             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10958             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10959 7         43 }
10960             else {
10961             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10962             }
10963             }
10964             }
10965 4         769  
10966 189 50       411 # make regexp string
10967 189         477 $modifier =~ tr/i//d;
10968             if ($left_e > $right_e) {
10969 0         0 return join '', 'Ekps9566::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
10970             }
10971             return join '', 'Ekps9566::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
10972             }
10973              
10974             #
10975             # escape regexp of split qr''
10976 189     112 0 1782 #
10977 112   100     603 sub e_split_q {
10978             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10979 112         373 $modifier ||= '';
10980 112 50       253  
10981 112         365 $modifier =~ tr/p//d;
10982 0         0 if ($modifier =~ /([adlu])/oxms) {
10983 0 0       0 my $line = 0;
10984 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10985 0         0 if ($filename ne __FILE__) {
10986             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10987             last;
10988 0         0 }
10989             }
10990             die qq{Unsupported modifier "$1" used at line $line.\n};
10991 0         0 }
10992              
10993             $slash = 'div';
10994 112 100       485  
10995 112         244 # /b /B modifier
10996             if ($modifier =~ tr/bB//d) {
10997             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10998 56 100       325 }
10999              
11000             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
11001 56         154  
11002             # split regexp
11003             my @char = $string =~ /\G((?>
11004             [^\x81-\xFE\\\[] |
11005             [\x81-\xFE][\x00-\xFF] |
11006             \[\^ |
11007             \[\: (?>[a-z]+) \:\] |
11008             \[\:\^ (?>[a-z]+) \:\] |
11009             \\ (?:$q_char) |
11010             (?:$q_char)
11011             ))/oxmsg;
11012 56         322  
11013 56 50 33     178 # unescape character
    50 100        
    50 66        
    50 33        
    50          
    100          
    50          
11014             for (my $i=0; $i <= $#char; $i++) {
11015             if (0) {
11016             }
11017 56         519  
11018 0         0 # escape last octet of multiple-octet
11019             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
11020             $char[$i] = $1 . '\\' . $2;
11021             }
11022              
11023 0         0 # open character class [...]
11024 0 0       0 elsif ($char[$i] eq '[') {
11025 0         0 my $left = $i;
11026             if ($char[$i+1] eq ']') {
11027 0         0 $i++;
11028 0 0       0 }
11029 0         0 while (1) {
11030             if (++$i > $#char) {
11031 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11032 0         0 }
11033             if ($char[$i] eq ']') {
11034             my $right = $i;
11035 0         0  
11036             # [...]
11037 0         0 splice @char, $left, $right-$left+1, Ekps9566::charlist_qr(@char[$left+1..$right-1], $modifier);
11038 0         0  
11039             $i = $left;
11040             last;
11041             }
11042             }
11043             }
11044              
11045 0         0 # open character class [^...]
11046 0 0       0 elsif ($char[$i] eq '[^') {
11047 0         0 my $left = $i;
11048             if ($char[$i+1] eq ']') {
11049 0         0 $i++;
11050 0 0       0 }
11051 0         0 while (1) {
11052             if (++$i > $#char) {
11053 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11054 0         0 }
11055             if ($char[$i] eq ']') {
11056             my $right = $i;
11057 0         0  
11058             # [^...]
11059 0         0 splice @char, $left, $right-$left+1, Ekps9566::charlist_not_qr(@char[$left+1..$right-1], $modifier);
11060 0         0  
11061             $i = $left;
11062             last;
11063             }
11064             }
11065             }
11066              
11067 0         0 # rewrite character class or escape character
11068             elsif (my $char = character_class($char[$i],$modifier)) {
11069             $char[$i] = $char;
11070             }
11071              
11072 0         0 # split(m/^/) --> split(m/^/m)
11073             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
11074             $modifier .= 'm';
11075             }
11076              
11077 0 50       0 # /i modifier
11078 12         38 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ekps9566::uc($char[$i]) ne Ekps9566::fc($char[$i]))) {
11079             if (CORE::length(Ekps9566::fc($char[$i])) == 1) {
11080             $char[$i] = '[' . Ekps9566::uc($char[$i]) . Ekps9566::fc($char[$i]) . ']';
11081 12         27 }
11082             else {
11083             $char[$i] = '(?:' . Ekps9566::uc($char[$i]) . '|' . Ekps9566::fc($char[$i]) . ')';
11084             }
11085             }
11086              
11087 0 0       0 # quote character before ? + * {
11088             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
11089             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
11090 0         0 }
11091             else {
11092             $char[$i-1] = '(?:' . $char[$i-1] . ')';
11093             }
11094             }
11095 0         0 }
11096 56         114  
11097             $modifier =~ tr/i//d;
11098             return join '', 'Ekps9566::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
11099             }
11100              
11101             #
11102             # escape use without import
11103 56     0 0 303 #
11104             sub e_use_noimport {
11105 0           my($module) = @_;
11106              
11107 0           my $expr = _pathof($module);
11108 0            
11109             my $fh = gensym();
11110 0 0         for my $realfilename (_realfilename($expr)) {
11111 0            
11112 0           if (Ekps9566::_open_r($fh, $realfilename)) {
11113 0 0         local $/ = undef; # slurp mode
11114             my $script = <$fh>;
11115 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11116 0            
11117             if ($script =~ /^ (?>\s*) use (?>\s+) KPS9566 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11118 0           return qq;
11119             }
11120             last;
11121             }
11122 0           }
11123              
11124             return qq;
11125             }
11126              
11127             #
11128             # escape no without unimport
11129 0     0 0   #
11130             sub e_no_nounimport {
11131 0           my($module) = @_;
11132              
11133 0           my $expr = _pathof($module);
11134 0            
11135             my $fh = gensym();
11136 0 0         for my $realfilename (_realfilename($expr)) {
11137 0            
11138 0           if (Ekps9566::_open_r($fh, $realfilename)) {
11139 0 0         local $/ = undef; # slurp mode
11140             my $script = <$fh>;
11141 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11142 0            
11143             if ($script =~ /^ (?>\s*) use (?>\s+) KPS9566 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11144 0           return qq;
11145             }
11146             last;
11147             }
11148 0           }
11149              
11150             return qq;
11151             }
11152              
11153             #
11154             # escape use with import no parameter
11155 0     0 0   #
11156             sub e_use_noparam {
11157 0           my($module) = @_;
11158              
11159 0           my $expr = _pathof($module);
11160 0            
11161             my $fh = gensym();
11162 0 0         for my $realfilename (_realfilename($expr)) {
11163 0            
11164 0           if (Ekps9566::_open_r($fh, $realfilename)) {
11165 0 0         local $/ = undef; # slurp mode
11166             my $script = <$fh>;
11167 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11168              
11169             if ($script =~ /^ (?>\s*) use (?>\s+) KPS9566 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11170              
11171             # P.326 UNIVERSAL: The Ultimate Ancestor Class
11172             # in Chapter 12: Objects
11173             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
11174              
11175             # P.435 UNIVERSAL: The Ultimate Ancestor Class
11176             # in Chapter 12: Objects
11177             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
11178              
11179 0           # (and so on)
11180              
11181 0           return qq[BEGIN { Ekps9566::require '$expr'; $module->import() if $module->can('import'); }];
11182             }
11183             last;
11184             }
11185 0           }
11186              
11187             return qq;
11188             }
11189              
11190             #
11191             # escape no with unimport no parameter
11192 0     0 0   #
11193             sub e_no_noparam {
11194 0           my($module) = @_;
11195              
11196 0           my $expr = _pathof($module);
11197 0            
11198             my $fh = gensym();
11199 0 0         for my $realfilename (_realfilename($expr)) {
11200 0            
11201 0           if (Ekps9566::_open_r($fh, $realfilename)) {
11202 0 0         local $/ = undef; # slurp mode
11203             my $script = <$fh>;
11204 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11205 0            
11206             if ($script =~ /^ (?>\s*) use (?>\s+) KPS9566 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11207 0           return qq[BEGIN { Ekps9566::require '$expr'; $module->unimport() if $module->can('unimport'); }];
11208             }
11209             last;
11210             }
11211 0           }
11212              
11213             return qq;
11214             }
11215              
11216             #
11217             # escape use with import parameters
11218 0     0 0   #
11219             sub e_use {
11220 0           my($module,$list) = @_;
11221              
11222 0           my $expr = _pathof($module);
11223 0            
11224             my $fh = gensym();
11225 0 0         for my $realfilename (_realfilename($expr)) {
11226 0            
11227 0           if (Ekps9566::_open_r($fh, $realfilename)) {
11228 0 0         local $/ = undef; # slurp mode
11229             my $script = <$fh>;
11230 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11231 0            
11232             if ($script =~ /^ (?>\s*) use (?>\s+) KPS9566 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11233 0           return qq[BEGIN { Ekps9566::require '$expr'; $module->import($list) if $module->can('import'); }];
11234             }
11235             last;
11236             }
11237 0           }
11238              
11239             return qq;
11240             }
11241              
11242             #
11243             # escape no with unimport parameters
11244 0     0 0   #
11245             sub e_no {
11246 0           my($module,$list) = @_;
11247              
11248 0           my $expr = _pathof($module);
11249 0            
11250             my $fh = gensym();
11251 0 0         for my $realfilename (_realfilename($expr)) {
11252 0            
11253 0           if (Ekps9566::_open_r($fh, $realfilename)) {
11254 0 0         local $/ = undef; # slurp mode
11255             my $script = <$fh>;
11256 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11257 0            
11258             if ($script =~ /^ (?>\s*) use (?>\s+) KPS9566 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11259 0           return qq[BEGIN { Ekps9566::require '$expr'; $module->unimport($list) if $module->can('unimport'); }];
11260             }
11261             last;
11262             }
11263 0           }
11264              
11265             return qq;
11266             }
11267              
11268             #
11269             # file path of module
11270 0     0     #
11271             sub _pathof {
11272 0 0         my($expr) = @_;
11273 0            
11274             if ($^O eq 'MacOS') {
11275             $expr =~ s#::#:#g;
11276 0           }
11277             else {
11278 0 0         $expr =~ s#::#/#g;
11279             }
11280 0           $expr .= '.pm' if $expr !~ / \.pm \z/oxmsi;
11281              
11282             return $expr;
11283             }
11284              
11285             #
11286             # real file name of module
11287 0     0     #
11288             sub _realfilename {
11289 0 0         my($expr) = @_;
11290 0            
  0            
11291             if ($^O eq 'MacOS') {
11292             return map {"$_$expr"} @INC;
11293 0           }
  0            
11294             else {
11295             return map {"$_/$expr"} @INC;
11296             }
11297             }
11298              
11299             #
11300             # instead of Carp::carp
11301 0     0 0   #
11302 0           sub carp {
11303             my($package,$filename,$line) = caller(1);
11304             print STDERR "@_ at $filename line $line.\n";
11305             }
11306              
11307             #
11308             # instead of Carp::croak
11309 0     0 0   #
11310 0           sub croak {
11311 0           my($package,$filename,$line) = caller(1);
11312             print STDERR "@_ at $filename line $line.\n";
11313             die "\n";
11314             }
11315              
11316             #
11317             # instead of Carp::cluck
11318 0     0 0   #
11319 0           sub cluck {
11320 0           my $i = 0;
11321 0           my @cluck = ();
11322 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11323             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
11324 0           $i++;
11325 0           }
11326 0           print STDERR CORE::reverse @cluck;
11327             print STDERR "\n";
11328             print STDERR @_;
11329             }
11330              
11331             #
11332             # instead of Carp::confess
11333 0     0 0   #
11334 0           sub confess {
11335 0           my $i = 0;
11336 0           my @confess = ();
11337 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11338             push @confess, "[$i] $filename($line) $package::$subroutine\n";
11339 0           $i++;
11340 0           }
11341 0           print STDERR CORE::reverse @confess;
11342 0           print STDERR "\n";
11343             print STDERR @_;
11344             die "\n";
11345             }
11346              
11347             1;
11348              
11349             __END__