File Coverage

blib/lib/Egbk.pm
Criterion Covered Total %
statement 1204 4693 25.6
branch 1360 4684 29.0
condition 162 496 32.6
subroutine 68 190 35.7
pod 8 148 5.4
total 2802 10211 27.4


line stmt bran cond sub pod time code
1             package Egbk;
2 389     389   12011 use strict;
  389         3747  
  389         31606  
3             ######################################################################
4             #
5             # Egbk - Run-time routines for GBK.pm
6             #
7             # http://search.cpan.org/dist/Char-GBK/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 389     389   7232 use 5.00503; # Galapagos Consensus 1998 for primetools
  389         2609  
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 389     389   2024 use vars qw($VERSION);
  389         4182  
  389         65620  
28             $VERSION = '1.15';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 389 50   389   4604 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 389         4853 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 389         56028 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 389     389   28728 CORE::eval q{
  389     389   6978  
  389     140   2215  
  389         48793  
  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 389 50       158719 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     1152 0 0 my($name) = @_;
78              
79 1152 50       2680 if (ref $name) {
    50          
    50          
    50          
    50          
    50          
    50          
80 1152         4463 return $name;
81             }
82             elsif (Egbk::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Egbk::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 1152         9028 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 50   1152 0 0 if (defined $_[1]) {
117 389     389   22252 no strict qw(refs);
  389         2503  
  389         46622  
118 1152         3626 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 389     389   5744 no strict qw(refs);
  389     0   2509  
  389         78059  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  1152         1836  
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 389     389   2414 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  389         2302  
  389         33900  
154 389     389   3442 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  389         768  
  389         636036  
155              
156             #
157             # GBK character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # GBK 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 Egbk \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0x80],
180             [0xFF..0xFF],
181             ],
182             2 => [ [0x81..0xFE],[0x40..0x7E],
183             [0x81..0xFE],[0x80..0xFE],
184             ],
185             );
186             }
187              
188             else {
189             croak "Don't know my package name '@{[__PACKAGE__]}'";
190             }
191              
192             #
193             # @ARGV wildcard globbing
194             #
195             sub import {
196              
197 1152 50   5   5766 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
198 5         91 my @argv = ();
199 0         0 for (@ARGV) {
200              
201             # has space
202 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
203 0 0       0 if (my @glob = Egbk::glob(qq{"$_"})) {
204 0         0 push @argv, @glob;
205             }
206             else {
207 0         0 push @argv, $_;
208             }
209             }
210              
211             # has wildcard metachar
212             elsif (/\A (?:$q_char)*? [*?] /oxms) {
213 0 0       0 if (my @glob = Egbk::glob($_)) {
214 0         0 push @argv, @glob;
215             }
216             else {
217 0         0 push @argv, $_;
218             }
219             }
220              
221             # no wildcard globbing
222             else {
223 0         0 push @argv, $_;
224             }
225             }
226 0         0 @ARGV = @argv;
227             }
228              
229 0         0 *Char::ord = \&GBK::ord;
230 5         30 *Char::ord_ = \&GBK::ord_;
231 5         14 *Char::reverse = \&GBK::reverse;
232 5         11 *Char::getc = \&GBK::getc;
233 5         11 *Char::length = \&GBK::length;
234 5         13 *Char::substr = \&GBK::substr;
235 5         11 *Char::index = \&GBK::index;
236 5         10 *Char::rindex = \&GBK::rindex;
237 5         11 *Char::eval = \&GBK::eval;
238 5         34 *Char::escape = \&GBK::escape;
239 5         12 *Char::escape_token = \&GBK::escape_token;
240 5         9 *Char::escape_script = \&GBK::escape_script;
241             }
242              
243             # P.230 Care with Prototypes
244             # in Chapter 6: Subroutines
245             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
246             #
247             # If you aren't careful, you can get yourself into trouble with prototypes.
248             # But if you are careful, you can do a lot of neat things with them. This is
249             # all very powerful, of course, and should only be used in moderation to make
250             # the world a better place.
251              
252             # P.332 Care with Prototypes
253             # in Chapter 7: Subroutines
254             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
255             #
256             # If you aren't careful, you can get yourself into trouble with prototypes.
257             # But if you are careful, you can do a lot of neat things with them. This is
258             # all very powerful, of course, and should only be used in moderation to make
259             # the world a better place.
260              
261             #
262             # Prototypes of subroutines
263             #
264       0     sub unimport {}
265             sub Egbk::split(;$$$);
266             sub Egbk::tr($$$$;$);
267             sub Egbk::chop(@);
268             sub Egbk::index($$;$);
269             sub Egbk::rindex($$;$);
270             sub Egbk::lcfirst(@);
271             sub Egbk::lcfirst_();
272             sub Egbk::lc(@);
273             sub Egbk::lc_();
274             sub Egbk::ucfirst(@);
275             sub Egbk::ucfirst_();
276             sub Egbk::uc(@);
277             sub Egbk::uc_();
278             sub Egbk::fc(@);
279             sub Egbk::fc_();
280             sub Egbk::ignorecase;
281             sub Egbk::classic_character_class;
282             sub Egbk::capture;
283             sub Egbk::chr(;$);
284             sub Egbk::chr_();
285             sub Egbk::filetest;
286             sub Egbk::r(;*@);
287             sub Egbk::w(;*@);
288             sub Egbk::x(;*@);
289             sub Egbk::o(;*@);
290             sub Egbk::R(;*@);
291             sub Egbk::W(;*@);
292             sub Egbk::X(;*@);
293             sub Egbk::O(;*@);
294             sub Egbk::e(;*@);
295             sub Egbk::z(;*@);
296             sub Egbk::s(;*@);
297             sub Egbk::f(;*@);
298             sub Egbk::d(;*@);
299             sub Egbk::l(;*@);
300             sub Egbk::p(;*@);
301             sub Egbk::S(;*@);
302             sub Egbk::b(;*@);
303             sub Egbk::c(;*@);
304             sub Egbk::u(;*@);
305             sub Egbk::g(;*@);
306             sub Egbk::k(;*@);
307             sub Egbk::T(;*@);
308             sub Egbk::B(;*@);
309             sub Egbk::M(;*@);
310             sub Egbk::A(;*@);
311             sub Egbk::C(;*@);
312             sub Egbk::filetest_;
313             sub Egbk::r_();
314             sub Egbk::w_();
315             sub Egbk::x_();
316             sub Egbk::o_();
317             sub Egbk::R_();
318             sub Egbk::W_();
319             sub Egbk::X_();
320             sub Egbk::O_();
321             sub Egbk::e_();
322             sub Egbk::z_();
323             sub Egbk::s_();
324             sub Egbk::f_();
325             sub Egbk::d_();
326             sub Egbk::l_();
327             sub Egbk::p_();
328             sub Egbk::S_();
329             sub Egbk::b_();
330             sub Egbk::c_();
331             sub Egbk::u_();
332             sub Egbk::g_();
333             sub Egbk::k_();
334             sub Egbk::T_();
335             sub Egbk::B_();
336             sub Egbk::M_();
337             sub Egbk::A_();
338             sub Egbk::C_();
339             sub Egbk::glob($);
340             sub Egbk::glob_();
341             sub Egbk::lstat(*);
342             sub Egbk::lstat_();
343             sub Egbk::opendir(*$);
344             sub Egbk::stat(*);
345             sub Egbk::stat_();
346             sub Egbk::unlink(@);
347             sub Egbk::chdir(;$);
348             sub Egbk::do($);
349             sub Egbk::require(;$);
350             sub Egbk::telldir(*);
351              
352             sub GBK::ord(;$);
353             sub GBK::ord_();
354             sub GBK::reverse(@);
355             sub GBK::getc(;*@);
356             sub GBK::length(;$);
357             sub GBK::substr($$;$$);
358             sub GBK::index($$;$);
359             sub GBK::rindex($$;$);
360             sub GBK::escape(;$);
361              
362             #
363             # Regexp work
364             #
365 389         40320 use vars qw(
366             $re_a
367             $re_t
368             $re_n
369             $re_r
370 389     389   3152 );
  389         3526  
371              
372             #
373             # Character class
374             #
375 389         101669 use vars qw(
376             $dot
377             $dot_s
378             $eD
379             $eS
380             $eW
381             $eH
382             $eV
383             $eR
384             $eN
385             $not_alnum
386             $not_alpha
387             $not_ascii
388             $not_blank
389             $not_cntrl
390             $not_digit
391             $not_graph
392             $not_lower
393             $not_lower_i
394             $not_print
395             $not_punct
396             $not_space
397             $not_upper
398             $not_upper_i
399             $not_word
400             $not_xdigit
401             $eb
402             $eB
403 389     389   3456 );
  389         1102  
404              
405 389         4553808 use vars qw(
406             $anchor
407             $matched
408 389     389   5153 );
  389         621  
409             ${Egbk::anchor} = qr{\G(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?}oxms;
410             my $q_char_SADAHIRO_Tomoyuki_2002_01_17 = '';
411              
412             # Quantifiers
413             # {n,m} --- Match at least n but not more than m times
414             #
415             # n and m are limited to non-negative integral values less than a
416             # preset limit defined when perl is built. This is usually 32766 on
417             # the most common platforms.
418             #
419             # The following code is an attempt to solve the above limitations
420             # in a multi-byte anchoring.
421              
422             # avoid "Segmentation fault" and "Error: Parse exception"
423              
424             # perl5101delta
425             # http://perldoc.perl.org/perl5101delta.html
426             # In 5.10.0, the * quantifier in patterns was sometimes treated as {0,32767}
427             # [RT #60034, #60464]. For example, this match would fail:
428             # ("ab" x 32768) =~ /^(ab)*$/
429              
430             # SEE ALSO
431             #
432             # Complex regular subexpression recursion limit
433             # http://www.perlmonks.org/?node_id=810857
434             #
435             # regexp iteration limits
436             # http://www.nntp.perl.org/group/perl.perl5.porters/2009/02/msg144065.html
437             #
438             # latest Perl won't match certain regexes more than 32768 characters long
439             # http://stackoverflow.com/questions/26226630/latest-perl-wont-match-certain-regexes-more-than-32768-characters-long
440             #
441             # Break through the limitations of regular expressions of Perl
442             # http://d.hatena.ne.jp/gfx/20110212/1297512479
443              
444             if (($] >= 5.010001) or
445             # ActivePerl 5.6 or later (include 5.10.0)
446             (defined($ActivePerl::VERSION) and ($ActivePerl::VERSION > 800)) or
447             (($^O eq 'MSWin32') and ($] =~ /\A 5\.006/oxms))
448             ) {
449             my $sbcs = ''; # Single Byte Character Set
450             for my $range (@{ $range_tr{1} }) {
451             $sbcs .= sprintf('\\x%02X-\\x%02X', $range->[0], $range->[-1]);
452             }
453              
454             if (0) {
455             }
456              
457             # other encoding
458             else {
459             ${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[$sbcs](?:[^$sbcs][^$sbcs])*?}oxms;
460             # ******* octets not in multiple octet char (always char boundary)
461             # **************** 2 octet chars
462             }
463              
464             ${Egbk::anchor_SADAHIRO_Tomoyuki_2002_01_17} =
465             qr{\G(?(?=.{0,32766}\z)(?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?|(?(?=[$sbcs]+\z).*?|(?:${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17})))}oxms;
466             # qr{
467             # \G # (1), (2)
468             # (? # (3)
469             # (?=.{0,32766}\z) # (4)
470             # (?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?| # (5)
471             # (?(?=[$sbcs]+\z) # (6)
472             # .*?| #(7)
473             # (?:${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17}) # (8)
474             # ))}oxms;
475              
476             # avoid: Complex regular subexpression recursion limit (32766) exceeded at here.
477             local $^W = 0;
478              
479             if (((('A' x 32768).'B') !~ / ${Egbk::anchor} B /oxms) and
480             ((('A' x 32768).'B') =~ / ${Egbk::anchor_SADAHIRO_Tomoyuki_2002_01_17} B /oxms)
481             ) {
482             ${Egbk::anchor} = ${Egbk::anchor_SADAHIRO_Tomoyuki_2002_01_17};
483             }
484             else {
485             undef ${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17};
486             }
487             }
488              
489             # (1)
490             # P.128 Start of match (or end of previous match): \G
491             # P.130 Advanced Use of \G with Perl
492             # in Chapter3: Over view of Regular Expression Features and Flavors
493             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
494              
495             # (2)
496             # P.255 Use leading anchors
497             # P.256 Expose ^ and \G at the front of expressions
498             # in Chapter6: Crafting an Efficient Expression
499             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
500              
501             # (3)
502             # P.138 Conditional: (? if then| else)
503             # in Chapter3: Over view of Regular Expression Features and Flavors
504             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
505              
506             # (4)
507             # perlre
508             # http://perldoc.perl.org/perlre.html
509             # The "*" quantifier is equivalent to {0,} , the "+" quantifier to {1,} ,
510             # and the "?" quantifier to {0,1}, ., n, and m are limited to non-negative
511             # integral values less than a preset limit defined when perl is built.
512             # This is usually 32766 on the most common platforms. The actual limit
513             # can be seen in the error message generated by code such as this:
514             # $_ **= $_ , / {$_} / for 2 .. 42;
515              
516             # (5)
517             # P.1023 Multiple-Byte Anchoring
518             # in Appendix W Perl Code Examples
519             # of ISBN 1-56592-224-7 CJKV Information Processing
520              
521             # (6)
522             # if string has only SBCS (Single Byte Character Set)
523              
524             # (7)
525             # then .*? (isn't limited to 32766)
526              
527             # (8)
528             # else GBK::Regexp::Const (SADAHIRO Tomoyuki)
529             # http://homepage1.nifty.com/nomenclator/perl/shiftjis.htm#long
530             # http://search.cpan.org/~sadahiro/GBK-Regexp/
531             # $PadA = ' (?:\A| [\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
532             # $PadG = '\G(?: |[\x00-\xFF]*?[\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
533             # $PadGA = '\G(?:\A|(?:[\x81-\xFE]{2})+?|[\x00-\xFF]*?[\x00-\x80\xA0-\xDF] (?:[\x81-\xFE]{2})*?)';
534              
535             ${Egbk::dot} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
536             ${Egbk::dot_s} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])};
537             ${Egbk::eD} = qr{(?>[^\x81-\xFE0-9]|[\x81-\xFE][\x00-\xFF])};
538              
539             # Vertical tabs are now whitespace
540             # \s in a regex now matches a vertical tab in all circumstances.
541             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
542             # ${Egbk::eS} = qr{(?>[^\x81-\xFE\x09\x0A \x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
543             # ${Egbk::eS} = qr{(?>[^\x81-\xFE\x09\x0A\x0B\x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
544             ${Egbk::eS} = qr{(?>[^\x81-\xFE\s]|[\x81-\xFE][\x00-\xFF])};
545              
546             ${Egbk::eW} = qr{(?>[^\x81-\xFE0-9A-Z_a-z]|[\x81-\xFE][\x00-\xFF])};
547             ${Egbk::eH} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
548             ${Egbk::eV} = qr{(?>[^\x81-\xFE\x0A\x0B\x0C\x0D]|[\x81-\xFE][\x00-\xFF])};
549             ${Egbk::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
550             ${Egbk::eN} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
551             ${Egbk::not_alnum} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
552             ${Egbk::not_alpha} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
553             ${Egbk::not_ascii} = qr{(?>[^\x81-\xFE\x00-\x7F]|[\x81-\xFE][\x00-\xFF])};
554             ${Egbk::not_blank} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
555             ${Egbk::not_cntrl} = qr{(?>[^\x81-\xFE\x00-\x1F\x7F]|[\x81-\xFE][\x00-\xFF])};
556             ${Egbk::not_digit} = qr{(?>[^\x81-\xFE\x30-\x39]|[\x81-\xFE][\x00-\xFF])};
557             ${Egbk::not_graph} = qr{(?>[^\x81-\xFE\x21-\x7F]|[\x81-\xFE][\x00-\xFF])};
558             ${Egbk::not_lower} = qr{(?>[^\x81-\xFE\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
559             ${Egbk::not_lower_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
560             # ${Egbk::not_lower_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
561             ${Egbk::not_print} = qr{(?>[^\x81-\xFE\x20-\x7F]|[\x81-\xFE][\x00-\xFF])};
562             ${Egbk::not_punct} = qr{(?>[^\x81-\xFE\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]|[\x81-\xFE][\x00-\xFF])};
563             ${Egbk::not_space} = qr{(?>[^\x81-\xFE\s\x0B]|[\x81-\xFE][\x00-\xFF])};
564             ${Egbk::not_upper} = qr{(?>[^\x81-\xFE\x41-\x5A]|[\x81-\xFE][\x00-\xFF])};
565             ${Egbk::not_upper_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
566             # ${Egbk::not_upper_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
567             ${Egbk::not_word} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x5F\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
568             ${Egbk::not_xdigit} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x46\x61-\x66]|[\x81-\xFE][\x00-\xFF])};
569             ${Egbk::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))};
570             ${Egbk::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]))};
571              
572             # avoid: Name "Egbk::foo" used only once: possible typo at here.
573             ${Egbk::dot} = ${Egbk::dot};
574             ${Egbk::dot_s} = ${Egbk::dot_s};
575             ${Egbk::eD} = ${Egbk::eD};
576             ${Egbk::eS} = ${Egbk::eS};
577             ${Egbk::eW} = ${Egbk::eW};
578             ${Egbk::eH} = ${Egbk::eH};
579             ${Egbk::eV} = ${Egbk::eV};
580             ${Egbk::eR} = ${Egbk::eR};
581             ${Egbk::eN} = ${Egbk::eN};
582             ${Egbk::not_alnum} = ${Egbk::not_alnum};
583             ${Egbk::not_alpha} = ${Egbk::not_alpha};
584             ${Egbk::not_ascii} = ${Egbk::not_ascii};
585             ${Egbk::not_blank} = ${Egbk::not_blank};
586             ${Egbk::not_cntrl} = ${Egbk::not_cntrl};
587             ${Egbk::not_digit} = ${Egbk::not_digit};
588             ${Egbk::not_graph} = ${Egbk::not_graph};
589             ${Egbk::not_lower} = ${Egbk::not_lower};
590             ${Egbk::not_lower_i} = ${Egbk::not_lower_i};
591             ${Egbk::not_print} = ${Egbk::not_print};
592             ${Egbk::not_punct} = ${Egbk::not_punct};
593             ${Egbk::not_space} = ${Egbk::not_space};
594             ${Egbk::not_upper} = ${Egbk::not_upper};
595             ${Egbk::not_upper_i} = ${Egbk::not_upper_i};
596             ${Egbk::not_word} = ${Egbk::not_word};
597             ${Egbk::not_xdigit} = ${Egbk::not_xdigit};
598             ${Egbk::eb} = ${Egbk::eb};
599             ${Egbk::eB} = ${Egbk::eB};
600              
601             #
602             # GBK split
603             #
604             sub Egbk::split(;$$$) {
605              
606             # P.794 29.2.161. split
607             # in Chapter 29: Functions
608             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
609              
610             # P.951 split
611             # in Chapter 27: Functions
612             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
613              
614 5     0 0 12136 my $pattern = $_[0];
615 0         0 my $string = $_[1];
616 0         0 my $limit = $_[2];
617              
618             # if $pattern is also omitted or is the literal space, " "
619 0 0       0 if (not defined $pattern) {
620 0         0 $pattern = ' ';
621             }
622              
623             # if $string is omitted, the function splits the $_ string
624 0 0       0 if (not defined $string) {
625 0 0       0 if (defined $_) {
626 0         0 $string = $_;
627             }
628             else {
629 0         0 $string = '';
630             }
631             }
632              
633 0         0 my @split = ();
634              
635             # when string is empty
636 0 0       0 if ($string eq '') {
    0          
637              
638             # resulting list value in list context
639 0 0       0 if (wantarray) {
640 0         0 return @split;
641             }
642              
643             # count of substrings in scalar context
644             else {
645 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
646 0         0 @_ = @split;
647 0         0 return scalar @_;
648             }
649             }
650              
651             # split's first argument is more consistently interpreted
652             #
653             # After some changes earlier in v5.17, split's behavior has been simplified:
654             # if the PATTERN argument evaluates to a string containing one space, it is
655             # treated the way that a literal string containing one space once was.
656             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
657              
658             # if $pattern is also omitted or is the literal space, " ", the function splits
659             # on whitespace, /\s+/, after skipping any leading whitespace
660             # (and so on)
661              
662             elsif ($pattern eq ' ') {
663 0 0       0 if (not defined $limit) {
664 0         0 return CORE::split(' ', $string);
665             }
666             else {
667 0         0 return CORE::split(' ', $string, $limit);
668             }
669             }
670              
671 0         0 local $q_char = $q_char;
672 0 0       0 if (CORE::length($string) > 32766) {
673 0 0       0 if ($string =~ /\A [\x00-\x7F]+ \z/oxms) {
    0          
674 0         0 $q_char = qr{.}s;
675             }
676             elsif (defined ${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17}) {
677 0         0 $q_char = ${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17};
678             }
679             }
680              
681             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
682 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
683              
684             # a pattern capable of matching either the null string or something longer than the
685             # null string will split the value of $string into separate characters wherever it
686             # matches the null string between characters
687             # (and so on)
688              
689 0 0       0 if ('' =~ / \A $pattern \z /xms) {
690 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
691 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
692              
693             # P.1024 Appendix W.10 Multibyte Processing
694             # of ISBN 1-56592-224-7 CJKV Information Processing
695             # (and so on)
696              
697             # the //m modifier is assumed when you split on the pattern /^/
698             # (and so on)
699              
700             # V
701 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
702              
703             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
704             # is included in the resulting list, interspersed with the fields that are ordinarily returned
705             # (and so on)
706              
707 0         0 local $@;
708 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
709 0         0 push @split, CORE::eval('$' . $digit);
710             }
711             }
712             }
713              
714             else {
715 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
716              
717             # V
718 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
719 0         0 local $@;
720 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
721 0         0 push @split, CORE::eval('$' . $digit);
722             }
723             }
724             }
725             }
726              
727             elsif ($limit > 0) {
728 0 0       0 if ('' =~ / \A $pattern \z /xms) {
729 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
730 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
731              
732             # V
733 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
734 0         0 local $@;
735 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
736 0         0 push @split, CORE::eval('$' . $digit);
737             }
738             }
739             }
740             }
741             else {
742 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
743 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
744              
745             # V
746 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
747 0         0 local $@;
748 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
749 0         0 push @split, CORE::eval('$' . $digit);
750             }
751             }
752             }
753             }
754             }
755              
756 0 0       0 if (CORE::length($string) > 0) {
757 0         0 push @split, $string;
758             }
759              
760             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
761 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
762 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
763 0         0 pop @split;
764             }
765             }
766              
767             # resulting list value in list context
768 0 0       0 if (wantarray) {
769 0         0 return @split;
770             }
771              
772             # count of substrings in scalar context
773             else {
774 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
775 0         0 @_ = @split;
776 0         0 return scalar @_;
777             }
778             }
779              
780             #
781             # get last subexpression offsets
782             #
783             sub _last_subexpression_offsets {
784 0     0   0 my $pattern = $_[0];
785              
786             # remove comment
787 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
788              
789 0         0 my $modifier = '';
790 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
791 0         0 $modifier = $1;
792 0         0 $modifier =~ s/-[A-Za-z]*//;
793             }
794              
795             # with /x modifier
796 0         0 my @char = ();
797 0 0       0 if ($modifier =~ /x/oxms) {
798 0         0 @char = $pattern =~ /\G((?>
799             [^\x81-\xFE\\\#\[\(]|[\x81-\xFE][\x00-\xFF] |
800             \\ $q_char |
801             \# (?>[^\n]*) $ |
802             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
803             \(\? |
804             $q_char
805             ))/oxmsg;
806             }
807              
808             # without /x modifier
809             else {
810 0         0 @char = $pattern =~ /\G((?>
811             [^\x81-\xFE\\\[\(]|[\x81-\xFE][\x00-\xFF] |
812             \\ $q_char |
813             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
814             \(\? |
815             $q_char
816             ))/oxmsg;
817             }
818              
819 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
820             }
821              
822             #
823             # GBK transliteration (tr///)
824             #
825             sub Egbk::tr($$$$;$) {
826              
827 0     0 0 0 my $bind_operator = $_[1];
828 0         0 my $searchlist = $_[2];
829 0         0 my $replacementlist = $_[3];
830 0   0     0 my $modifier = $_[4] || '';
831              
832 0 0       0 if ($modifier =~ /r/oxms) {
833 0 0       0 if ($bind_operator =~ / !~ /oxms) {
834 0         0 croak "Using !~ with tr///r doesn't make sense";
835             }
836             }
837              
838 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
839 0         0 my @searchlist = _charlist_tr($searchlist);
840 0         0 my @replacementlist = _charlist_tr($replacementlist);
841              
842 0         0 my %tr = ();
843 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
844 0 0       0 if (not exists $tr{$searchlist[$i]}) {
845 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
846 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
847             }
848             elsif ($modifier =~ /d/oxms) {
849 0         0 $tr{$searchlist[$i]} = '';
850             }
851             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
852 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
853             }
854             else {
855 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
856             }
857             }
858             }
859              
860 0         0 my $tr = 0;
861 0         0 my $replaced = '';
862 0 0       0 if ($modifier =~ /c/oxms) {
863 0         0 while (defined(my $char = shift @char)) {
864 0 0       0 if (not exists $tr{$char}) {
865 0 0       0 if (defined $replacementlist[0]) {
866 0         0 $replaced .= $replacementlist[0];
867             }
868 0         0 $tr++;
869 0 0       0 if ($modifier =~ /s/oxms) {
870 0   0     0 while (@char and (not exists $tr{$char[0]})) {
871 0         0 shift @char;
872 0         0 $tr++;
873             }
874             }
875             }
876             else {
877 0         0 $replaced .= $char;
878             }
879             }
880             }
881             else {
882 0         0 while (defined(my $char = shift @char)) {
883 0 0       0 if (exists $tr{$char}) {
884 0         0 $replaced .= $tr{$char};
885 0         0 $tr++;
886 0 0       0 if ($modifier =~ /s/oxms) {
887 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
888 0         0 shift @char;
889 0         0 $tr++;
890             }
891             }
892             }
893             else {
894 0         0 $replaced .= $char;
895             }
896             }
897             }
898              
899 0 0       0 if ($modifier =~ /r/oxms) {
900 0         0 return $replaced;
901             }
902             else {
903 0         0 $_[0] = $replaced;
904 0 0       0 if ($bind_operator =~ / !~ /oxms) {
905 0         0 return not $tr;
906             }
907             else {
908 0         0 return $tr;
909             }
910             }
911             }
912              
913             #
914             # GBK chop
915             #
916             sub Egbk::chop(@) {
917              
918 0     0 0 0 my $chop;
919 0 0       0 if (@_ == 0) {
920 0         0 my @char = /\G (?>$q_char) /oxmsg;
921 0         0 $chop = pop @char;
922 0         0 $_ = join '', @char;
923             }
924             else {
925 0         0 for (@_) {
926 0         0 my @char = /\G (?>$q_char) /oxmsg;
927 0         0 $chop = pop @char;
928 0         0 $_ = join '', @char;
929             }
930             }
931 0         0 return $chop;
932             }
933              
934             #
935             # GBK index by octet
936             #
937             sub Egbk::index($$;$) {
938              
939 0     2304 1 0 my($str,$substr,$position) = @_;
940 2304   50     4864 $position ||= 0;
941 2304         8581 my $pos = 0;
942              
943 2304         2746 while ($pos < CORE::length($str)) {
944 2304 50       4827 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
945 49308 0       71891 if ($pos >= $position) {
946 0         0 return $pos;
947             }
948             }
949 0 50       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
950 49308         107068 $pos += CORE::length($1);
951             }
952             else {
953 49308         80432 $pos += 1;
954             }
955             }
956 0         0 return -1;
957             }
958              
959             #
960             # GBK reverse index
961             #
962             sub Egbk::rindex($$;$) {
963              
964 2304     0 0 24651 my($str,$substr,$position) = @_;
965 0   0     0 $position ||= CORE::length($str) - 1;
966 0         0 my $pos = 0;
967 0         0 my $rindex = -1;
968              
969 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
970 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
971 0         0 $rindex = $pos;
972             }
973 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
974 0         0 $pos += CORE::length($1);
975             }
976             else {
977 0         0 $pos += 1;
978             }
979             }
980 0         0 return $rindex;
981             }
982              
983             #
984             # GBK lower case first with parameter
985             #
986             sub Egbk::lcfirst(@) {
987 0 0   0 0 0 if (@_) {
988 0         0 my $s = shift @_;
989 0 0 0     0 if (@_ and wantarray) {
990 0         0 return Egbk::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
991             }
992             else {
993 0         0 return Egbk::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
994             }
995             }
996             else {
997 0         0 return Egbk::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
998             }
999             }
1000              
1001             #
1002             # GBK lower case first without parameter
1003             #
1004             sub Egbk::lcfirst_() {
1005 0     0 0 0 return Egbk::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1006             }
1007              
1008             #
1009             # GBK lower case with parameter
1010             #
1011             sub Egbk::lc(@) {
1012 0 0   0 0 0 if (@_) {
1013 0         0 my $s = shift @_;
1014 0 0 0     0 if (@_ and wantarray) {
1015 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1016             }
1017             else {
1018 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1019             }
1020             }
1021             else {
1022 0         0 return Egbk::lc_();
1023             }
1024             }
1025              
1026             #
1027             # GBK lower case without parameter
1028             #
1029             sub Egbk::lc_() {
1030 0     0 0 0 my $s = $_;
1031 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1032             }
1033              
1034             #
1035             # GBK upper case first with parameter
1036             #
1037             sub Egbk::ucfirst(@) {
1038 0 0   0 0 0 if (@_) {
1039 0         0 my $s = shift @_;
1040 0 0 0     0 if (@_ and wantarray) {
1041 0         0 return Egbk::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1042             }
1043             else {
1044 0         0 return Egbk::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1045             }
1046             }
1047             else {
1048 0         0 return Egbk::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1049             }
1050             }
1051              
1052             #
1053             # GBK upper case first without parameter
1054             #
1055             sub Egbk::ucfirst_() {
1056 0     0 0 0 return Egbk::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1057             }
1058              
1059             #
1060             # GBK upper case with parameter
1061             #
1062             sub Egbk::uc(@) {
1063 0 50   2968 0 0 if (@_) {
1064 2968         4030 my $s = shift @_;
1065 2968 50 33     3505 if (@_ and wantarray) {
1066 2968 0       4720 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1067             }
1068             else {
1069 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  2968         7893  
1070             }
1071             }
1072             else {
1073 2968         9512 return Egbk::uc_();
1074             }
1075             }
1076              
1077             #
1078             # GBK upper case without parameter
1079             #
1080             sub Egbk::uc_() {
1081 0     0 0 0 my $s = $_;
1082 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1083             }
1084              
1085             #
1086             # GBK fold case with parameter
1087             #
1088             sub Egbk::fc(@) {
1089 0 50   3271 0 0 if (@_) {
1090 3271         4284 my $s = shift @_;
1091 3271 50 33     3653 if (@_ and wantarray) {
1092 3271 0       5318 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1093             }
1094             else {
1095 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3271         7754  
1096             }
1097             }
1098             else {
1099 3271         11656 return Egbk::fc_();
1100             }
1101             }
1102              
1103             #
1104             # GBK fold case without parameter
1105             #
1106             sub Egbk::fc_() {
1107 0     0 0 0 my $s = $_;
1108 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1109             }
1110              
1111             #
1112             # GBK regexp capture
1113             #
1114             {
1115             # 10.3. Creating Persistent Private Variables
1116             # in Chapter 10. Subroutines
1117             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
1118              
1119             my $last_s_matched = 0;
1120              
1121             sub Egbk::capture {
1122 0 0 0 0 1 0 if ($last_s_matched and ($_[0] =~ /\A (?>[1-9][0-9]*) \z/oxms)) {
1123 0         0 return $_[0] + 1;
1124             }
1125 0         0 return $_[0];
1126             }
1127              
1128             # GBK mark last regexp matched
1129             sub Egbk::matched() {
1130 0     0 0 0 $last_s_matched = 0;
1131             }
1132              
1133             # GBK mark last s/// matched
1134             sub Egbk::s_matched() {
1135 0     0 0 0 $last_s_matched = 1;
1136             }
1137              
1138             # P.854 31.17. use re
1139             # in Chapter 31. Pragmatic Modules
1140             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1141              
1142             # P.1026 re
1143             # in Chapter 29. Pragmatic Modules
1144             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1145              
1146             $Egbk::matched = qr/(?{Egbk::matched})/;
1147             }
1148              
1149             #
1150             # GBK regexp ignore case modifier
1151             #
1152             sub Egbk::ignorecase {
1153              
1154 0     0 0 0 my @string = @_;
1155 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1156              
1157             # ignore case of $scalar or @array
1158 0         0 for my $string (@string) {
1159              
1160             # split regexp
1161 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1162              
1163             # unescape character
1164 0         0 for (my $i=0; $i <= $#char; $i++) {
1165 0 0       0 next if not defined $char[$i];
1166              
1167             # open character class [...]
1168 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1169 0         0 my $left = $i;
1170              
1171             # [] make die "unmatched [] in regexp ...\n"
1172              
1173 0 0       0 if ($char[$i+1] eq ']') {
1174 0         0 $i++;
1175             }
1176              
1177 0         0 while (1) {
1178 0 0       0 if (++$i > $#char) {
1179 0         0 croak "Unmatched [] in regexp";
1180             }
1181 0 0       0 if ($char[$i] eq ']') {
1182 0         0 my $right = $i;
1183 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1184              
1185             # escape character
1186 0         0 for my $char (@charlist) {
1187 0 0       0 if (0) {
    0          
1188             }
1189              
1190             # do not use quotemeta here
1191 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1192 0         0 $char = $1 . '\\' . $2;
1193             }
1194             elsif ($char =~ /\A [.|)] \z/oxms) {
1195 0         0 $char = '\\' . $char;
1196             }
1197             }
1198              
1199             # [...]
1200 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1201              
1202 0         0 $i = $left;
1203 0         0 last;
1204             }
1205             }
1206             }
1207              
1208             # open character class [^...]
1209             elsif ($char[$i] eq '[^') {
1210 0         0 my $left = $i;
1211              
1212             # [^] make die "unmatched [] in regexp ...\n"
1213              
1214 0 0       0 if ($char[$i+1] eq ']') {
1215 0         0 $i++;
1216             }
1217              
1218 0         0 while (1) {
1219 0 0       0 if (++$i > $#char) {
1220 0         0 croak "Unmatched [] in regexp";
1221             }
1222 0 0       0 if ($char[$i] eq ']') {
1223 0         0 my $right = $i;
1224 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1225              
1226             # escape character
1227 0         0 for my $char (@charlist) {
1228 0 0       0 if (0) {
    0          
1229             }
1230              
1231             # do not use quotemeta here
1232 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1233 0         0 $char = $1 . '\\' . $2;
1234             }
1235             elsif ($char =~ /\A [.|)] \z/oxms) {
1236 0         0 $char = '\\' . $char;
1237             }
1238             }
1239              
1240             # [^...]
1241 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1242              
1243 0         0 $i = $left;
1244 0         0 last;
1245             }
1246             }
1247             }
1248              
1249             # rewrite classic character class or escape character
1250             elsif (my $char = classic_character_class($char[$i])) {
1251 0         0 $char[$i] = $char;
1252             }
1253              
1254             # with /i modifier
1255             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1256 0         0 my $uc = Egbk::uc($char[$i]);
1257 0         0 my $fc = Egbk::fc($char[$i]);
1258 0 0       0 if ($uc ne $fc) {
1259 0 0       0 if (CORE::length($fc) == 1) {
1260 0         0 $char[$i] = '[' . $uc . $fc . ']';
1261             }
1262             else {
1263 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1264             }
1265             }
1266             }
1267             }
1268              
1269             # characterize
1270 0         0 for (my $i=0; $i <= $#char; $i++) {
1271 0 0       0 next if not defined $char[$i];
1272              
1273 0 0 0     0 if (0) {
    0          
1274             }
1275              
1276             # escape last octet of multiple-octet
1277 0         0 elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1278 0         0 $char[$i] = $1 . '\\' . $2;
1279             }
1280              
1281             # quote character before ? + * {
1282             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1283 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1284 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1285             }
1286             }
1287             }
1288              
1289 0         0 $string = join '', @char;
1290             }
1291              
1292             # make regexp string
1293 0         0 return @string;
1294             }
1295              
1296             #
1297             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1298             #
1299             sub Egbk::classic_character_class {
1300 0     5319 0 0 my($char) = @_;
1301              
1302             return {
1303             '\D' => '${Egbk::eD}',
1304             '\S' => '${Egbk::eS}',
1305             '\W' => '${Egbk::eW}',
1306             '\d' => '[0-9]',
1307              
1308             # Before Perl 5.6, \s only matched the five whitespace characters
1309             # tab, newline, form-feed, carriage return, and the space character
1310             # itself, which, taken together, is the character class [\t\n\f\r ].
1311              
1312             # Vertical tabs are now whitespace
1313             # \s in a regex now matches a vertical tab in all circumstances.
1314             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1315             # \t \n \v \f \r space
1316             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1317             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1318             '\s' => '\s',
1319              
1320             '\w' => '[0-9A-Z_a-z]',
1321             '\C' => '[\x00-\xFF]',
1322             '\X' => 'X',
1323              
1324             # \h \v \H \V
1325              
1326             # P.114 Character Class Shortcuts
1327             # in Chapter 7: In the World of Regular Expressions
1328             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1329              
1330             # P.357 13.2.3 Whitespace
1331             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1332             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1333             #
1334             # 0x00009 CHARACTER TABULATION h s
1335             # 0x0000a LINE FEED (LF) vs
1336             # 0x0000b LINE TABULATION v
1337             # 0x0000c FORM FEED (FF) vs
1338             # 0x0000d CARRIAGE RETURN (CR) vs
1339             # 0x00020 SPACE h s
1340              
1341             # P.196 Table 5-9. Alphanumeric regex metasymbols
1342             # in Chapter 5. Pattern Matching
1343             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1344              
1345             # (and so on)
1346              
1347             '\H' => '${Egbk::eH}',
1348             '\V' => '${Egbk::eV}',
1349             '\h' => '[\x09\x20]',
1350             '\v' => '[\x0A\x0B\x0C\x0D]',
1351             '\R' => '${Egbk::eR}',
1352              
1353             # \N
1354             #
1355             # http://perldoc.perl.org/perlre.html
1356             # Character Classes and other Special Escapes
1357             # Any character but \n (experimental). Not affected by /s modifier
1358              
1359             '\N' => '${Egbk::eN}',
1360              
1361             # \b \B
1362              
1363             # P.180 Boundaries: The \b and \B Assertions
1364             # in Chapter 5: Pattern Matching
1365             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1366              
1367             # P.219 Boundaries: The \b and \B Assertions
1368             # in Chapter 5: Pattern Matching
1369             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1370              
1371             # \b really means (?:(?<=\w)(?!\w)|(?
1372             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1373             '\b' => '${Egbk::eb}',
1374              
1375             # \B really means (?:(?<=\w)(?=\w)|(?
1376             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1377             '\B' => '${Egbk::eB}',
1378              
1379 5319   100     7001 }->{$char} || '';
1380             }
1381              
1382             #
1383             # prepare GBK characters per length
1384             #
1385              
1386             # 1 octet characters
1387             my @chars1 = ();
1388             sub chars1 {
1389 5319 0   0 0 163157 if (@chars1) {
1390 0         0 return @chars1;
1391             }
1392 0 0       0 if (exists $range_tr{1}) {
1393 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1394 0         0 while (my @range = splice(@ranges,0,1)) {
1395 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1396 0         0 push @chars1, pack 'C', $oct0;
1397             }
1398             }
1399             }
1400 0         0 return @chars1;
1401             }
1402              
1403             # 2 octets characters
1404             my @chars2 = ();
1405             sub chars2 {
1406 0 0   0 0 0 if (@chars2) {
1407 0         0 return @chars2;
1408             }
1409 0 0       0 if (exists $range_tr{2}) {
1410 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1411 0         0 while (my @range = splice(@ranges,0,2)) {
1412 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1413 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1414 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1415             }
1416             }
1417             }
1418             }
1419 0         0 return @chars2;
1420             }
1421              
1422             # 3 octets characters
1423             my @chars3 = ();
1424             sub chars3 {
1425 0 0   0 0 0 if (@chars3) {
1426 0         0 return @chars3;
1427             }
1428 0 0       0 if (exists $range_tr{3}) {
1429 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1430 0         0 while (my @range = splice(@ranges,0,3)) {
1431 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1432 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1433 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1434 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1435             }
1436             }
1437             }
1438             }
1439             }
1440 0         0 return @chars3;
1441             }
1442              
1443             # 4 octets characters
1444             my @chars4 = ();
1445             sub chars4 {
1446 0 0   0 0 0 if (@chars4) {
1447 0         0 return @chars4;
1448             }
1449 0 0       0 if (exists $range_tr{4}) {
1450 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1451 0         0 while (my @range = splice(@ranges,0,4)) {
1452 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1453 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1454 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1455 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1456 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1457             }
1458             }
1459             }
1460             }
1461             }
1462             }
1463 0         0 return @chars4;
1464             }
1465              
1466             #
1467             # GBK open character list for tr
1468             #
1469             sub _charlist_tr {
1470              
1471 0     0   0 local $_ = shift @_;
1472              
1473             # unescape character
1474 0         0 my @char = ();
1475 0         0 while (not /\G \z/oxmsgc) {
1476 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1477 0         0 push @char, '\-';
1478             }
1479             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1480 0         0 push @char, CORE::chr(oct $1);
1481             }
1482             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1483 0         0 push @char, CORE::chr(hex $1);
1484             }
1485             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1486 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1487             }
1488             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1489             push @char, {
1490             '\0' => "\0",
1491             '\n' => "\n",
1492             '\r' => "\r",
1493             '\t' => "\t",
1494             '\f' => "\f",
1495             '\b' => "\x08", # \b means backspace in character class
1496             '\a' => "\a",
1497             '\e' => "\e",
1498 0         0 }->{$1};
1499             }
1500             elsif (/\G \\ ($q_char) /oxmsgc) {
1501 0         0 push @char, $1;
1502             }
1503             elsif (/\G ($q_char) /oxmsgc) {
1504 0         0 push @char, $1;
1505             }
1506             }
1507              
1508             # join separated multiple-octet
1509 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1510              
1511             # unescape '-'
1512 0         0 my @i = ();
1513 0         0 for my $i (0 .. $#char) {
1514 0 0       0 if ($char[$i] eq '\-') {
    0          
1515 0         0 $char[$i] = '-';
1516             }
1517             elsif ($char[$i] eq '-') {
1518 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1519 0         0 push @i, $i;
1520             }
1521             }
1522             }
1523              
1524             # open character list (reverse for splice)
1525 0         0 for my $i (CORE::reverse @i) {
1526 0         0 my @range = ();
1527              
1528             # range error
1529 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1530 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1531             }
1532              
1533             # range of multiple-octet code
1534 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1535 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1536 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1537             }
1538             elsif (CORE::length($char[$i+1]) == 2) {
1539 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1540 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1541             }
1542             elsif (CORE::length($char[$i+1]) == 3) {
1543 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1544 0         0 push @range, chars2();
1545 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1546             }
1547             elsif (CORE::length($char[$i+1]) == 4) {
1548 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1549 0         0 push @range, chars2();
1550 0         0 push @range, chars3();
1551 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1552             }
1553             else {
1554 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1555             }
1556             }
1557             elsif (CORE::length($char[$i-1]) == 2) {
1558 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1559 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1560             }
1561             elsif (CORE::length($char[$i+1]) == 3) {
1562 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1563 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1564             }
1565             elsif (CORE::length($char[$i+1]) == 4) {
1566 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1567 0         0 push @range, chars3();
1568 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1569             }
1570             else {
1571 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1572             }
1573             }
1574             elsif (CORE::length($char[$i-1]) == 3) {
1575 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1576 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1577             }
1578             elsif (CORE::length($char[$i+1]) == 4) {
1579 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1580 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1581             }
1582             else {
1583 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1584             }
1585             }
1586             elsif (CORE::length($char[$i-1]) == 4) {
1587 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1588 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1589             }
1590             else {
1591 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1592             }
1593             }
1594             else {
1595 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1596             }
1597              
1598 0         0 splice @char, $i-1, 3, @range;
1599             }
1600              
1601 0         0 return @char;
1602             }
1603              
1604             #
1605             # GBK open character class
1606             #
1607             sub _cc {
1608 0 50   604   0 if (scalar(@_) == 0) {
    100          
    50          
1609 604         1156 die __FILE__, ": subroutine cc got no parameter.\n";
1610             }
1611             elsif (scalar(@_) == 1) {
1612 0         0 return sprintf('\x%02X',$_[0]);
1613             }
1614             elsif (scalar(@_) == 2) {
1615 302 50       930 if ($_[0] > $_[1]) {
    50          
    50          
1616 302         741 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1617             }
1618             elsif ($_[0] == $_[1]) {
1619 0         0 return sprintf('\x%02X',$_[0]);
1620             }
1621             elsif (($_[0]+1) == $_[1]) {
1622 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1623             }
1624             else {
1625 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1626             }
1627             }
1628             else {
1629 302         1476 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1630             }
1631             }
1632              
1633             #
1634             # GBK octet range
1635             #
1636             sub _octets {
1637 0     668   0 my $length = shift @_;
1638              
1639 668 100       988 if ($length == 1) {
    50          
    0          
    0          
1640 668         1306 my($a1) = unpack 'C', $_[0];
1641 406         1018 my($z1) = unpack 'C', $_[1];
1642              
1643 406 50       681 if ($a1 > $z1) {
1644 406         1416 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1645             }
1646              
1647 0 100       0 if ($a1 == $z1) {
    50          
1648 406         960 return sprintf('\x%02X',$a1);
1649             }
1650             elsif (($a1+1) == $z1) {
1651 20         91 return sprintf('\x%02X\x%02X',$a1,$z1);
1652             }
1653             else {
1654 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1655             }
1656             }
1657             elsif ($length == 2) {
1658 386         2501 my($a1,$a2) = unpack 'CC', $_[0];
1659 262         573 my($z1,$z2) = unpack 'CC', $_[1];
1660 262         433 my($A1,$A2) = unpack 'CC', $_[2];
1661 262         402 my($Z1,$Z2) = unpack 'CC', $_[3];
1662              
1663 262 100       405 if ($a1 == $z1) {
    50          
1664             return (
1665             # 11111111 222222222222
1666             # A A Z
1667 262         425 _cc($a1) . _cc($a2,$z2), # a2-z2
1668             );
1669             }
1670             elsif (($a1+1) == $z1) {
1671             return (
1672             # 11111111111 222222222222
1673             # A Z A Z
1674 222         350 _cc($a1) . _cc($a2,$Z2), # a2-
1675             _cc( $z1) . _cc($A2,$z2), # -z2
1676             );
1677             }
1678             else {
1679             return (
1680             # 1111111111111111 222222222222
1681             # A Z A Z
1682 40         72 _cc($a1) . _cc($a2,$Z2), # a2-
1683             _cc($a1+1,$z1-1) . _cc($A2,$Z2), # -
1684             _cc( $z1) . _cc($A2,$z2), # -z2
1685             );
1686             }
1687             }
1688             elsif ($length == 3) {
1689 0         0 my($a1,$a2,$a3) = unpack 'CCC', $_[0];
1690 0         0 my($z1,$z2,$z3) = unpack 'CCC', $_[1];
1691 0         0 my($A1,$A2,$A3) = unpack 'CCC', $_[2];
1692 0         0 my($Z1,$Z2,$Z3) = unpack 'CCC', $_[3];
1693              
1694 0 0       0 if ($a1 == $z1) {
    0          
1695 0 0       0 if ($a2 == $z2) {
    0          
1696             return (
1697             # 11111111 22222222 333333333333
1698             # A A A Z
1699 0         0 _cc($a1) . _cc($a2) . _cc($a3,$z3), # a3-z3
1700             );
1701             }
1702             elsif (($a2+1) == $z2) {
1703             return (
1704             # 11111111 22222222222 333333333333
1705             # A A Z A Z
1706 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1707             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1708             );
1709             }
1710             else {
1711             return (
1712             # 11111111 2222222222222222 333333333333
1713             # A A Z A Z
1714 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1715             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3), # -
1716             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1717             );
1718             }
1719             }
1720             elsif (($a1+1) == $z1) {
1721             return (
1722             # 11111111111 22222222222222 333333333333
1723             # A Z A Z A Z
1724 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1725             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1726             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1727             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1728             );
1729             }
1730             else {
1731             return (
1732             # 1111111111111111 22222222222222 333333333333
1733             # A Z A Z A Z
1734 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1735             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1736             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3), # -
1737             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1738             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1739             );
1740             }
1741             }
1742             elsif ($length == 4) {
1743 0         0 my($a1,$a2,$a3,$a4) = unpack 'CCCC', $_[0];
1744 0         0 my($z1,$z2,$z3,$z4) = unpack 'CCCC', $_[1];
1745 0         0 my($A1,$A2,$A3,$A4) = unpack 'CCCC', $_[0];
1746 0         0 my($Z1,$Z2,$Z3,$Z4) = unpack 'CCCC', $_[1];
1747              
1748 0 0       0 if ($a1 == $z1) {
    0          
1749 0 0       0 if ($a2 == $z2) {
    0          
1750 0 0       0 if ($a3 == $z3) {
    0          
1751             return (
1752             # 11111111 22222222 33333333 444444444444
1753             # A A A A Z
1754 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$z4), # a4-z4
1755             );
1756             }
1757             elsif (($a3+1) == $z3) {
1758             return (
1759             # 11111111 22222222 33333333333 444444444444
1760             # A A A Z A Z
1761 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1762             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1763             );
1764             }
1765             else {
1766             return (
1767             # 11111111 22222222 3333333333333333 444444444444
1768             # A A A Z A Z
1769 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1770             _cc($a1) . _cc($a2) . _cc($a3+1,$z3-1) . _cc($A4,$Z4), # -
1771             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1772             );
1773             }
1774             }
1775             elsif (($a2+1) == $z2) {
1776             return (
1777             # 11111111 22222222222 33333333333333 444444444444
1778             # A A Z A Z A Z
1779 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1780             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1781             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1782             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1783             );
1784             }
1785             else {
1786             return (
1787             # 11111111 2222222222222222 33333333333333 444444444444
1788             # A A Z A Z A Z
1789 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1790             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1791             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1792             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1793             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1794             );
1795             }
1796             }
1797             elsif (($a1+1) == $z1) {
1798             return (
1799             # 11111111111 22222222222222 33333333333333 444444444444
1800             # A Z A Z A Z A Z
1801 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1802             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1803             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1804             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1805             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1806             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1807             );
1808             }
1809             else {
1810             return (
1811             # 1111111111111111 22222222222222 33333333333333 444444444444
1812             # A Z A Z A Z A Z
1813 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1814             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1815             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1816             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1817             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1818             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1819             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1820             );
1821             }
1822             }
1823             else {
1824 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1825             }
1826             }
1827              
1828             #
1829             # GBK range regexp
1830             #
1831             sub _range_regexp {
1832 0     517   0 my($length,$first,$last) = @_;
1833              
1834 517         1098 my @range_regexp = ();
1835 517 50       724 if (not exists $range_tr{$length}) {
1836 517         1144 return @range_regexp;
1837             }
1838              
1839 0         0 my @ranges = @{ $range_tr{$length} };
  517         652  
1840 517         1129 while (my @range = splice(@ranges,0,$length)) {
1841 517         1485 my $min = '';
1842 1034         1365 my $max = '';
1843 1034         1115 for (my $i=0; $i < $length; $i++) {
1844 1034         1813 $min .= pack 'C', $range[$i][0];
1845 1296         2753 $max .= pack 'C', $range[$i][-1];
1846             }
1847              
1848             # min___max
1849             # FIRST_____________LAST
1850             # (nothing)
1851              
1852 1296 50 66     2413 if ($max lt $first) {
    100 100        
    50 33        
    100 100        
    100 66        
    100 66        
    50 66        
1853             }
1854              
1855             # **********
1856             # min_________max
1857             # FIRST_____________LAST
1858             # **********
1859              
1860             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1861 1034         8477 push @range_regexp, _octets($length,$first,$max,$min,$max);
1862             }
1863              
1864             # **********************
1865             # min________________max
1866             # FIRST_____________LAST
1867             # **********************
1868              
1869             elsif (($min eq $first) and ($max eq $last)) {
1870 20         52 push @range_regexp, _octets($length,$first,$last,$min,$max);
1871             }
1872              
1873             # *********
1874             # min___max
1875             # FIRST_____________LAST
1876             # *********
1877              
1878             elsif (($first le $min) and ($max le $last)) {
1879 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1880             }
1881              
1882             # **********************
1883             # min__________________________max
1884             # FIRST_____________LAST
1885             # **********************
1886              
1887             elsif (($min le $first) and ($last le $max)) {
1888 20         46 push @range_regexp, _octets($length,$first,$last,$min,$max);
1889             }
1890              
1891             # *********
1892             # min________max
1893             # FIRST_____________LAST
1894             # *********
1895              
1896             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1897 588         1301 push @range_regexp, _octets($length,$min,$last,$min,$max);
1898             }
1899              
1900             # min___max
1901             # FIRST_____________LAST
1902             # (nothing)
1903              
1904             elsif ($last lt $min) {
1905             }
1906              
1907             else {
1908 40         72 die __FILE__, ": subroutine _range_regexp panic.\n";
1909             }
1910             }
1911              
1912 0         0 return @range_regexp;
1913             }
1914              
1915             #
1916             # GBK open character list for qr and not qr
1917             #
1918             sub _charlist {
1919              
1920 517     758   1192 my $modifier = pop @_;
1921 758         1119 my @char = @_;
1922              
1923 758 100       1538 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1924              
1925             # unescape character
1926 758         1739 for (my $i=0; $i <= $#char; $i++) {
1927              
1928             # escape - to ...
1929 758 100 100     2360 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1930 2648 100 100     17073 if ((0 < $i) and ($i < $#char)) {
1931 522         1718 $char[$i] = '...';
1932             }
1933             }
1934              
1935             # octal escape sequence
1936             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1937 497         993 $char[$i] = octchr($1);
1938             }
1939              
1940             # hexadecimal escape sequence
1941             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1942 0         0 $char[$i] = hexchr($1);
1943             }
1944              
1945             # \b{...} --> b\{...}
1946             # \B{...} --> B\{...}
1947             # \N{CHARNAME} --> N\{CHARNAME}
1948             # \p{PROPERTY} --> p\{PROPERTY}
1949             # \P{PROPERTY} --> P\{PROPERTY}
1950             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
1951 0         0 $char[$i] = $1 . '\\' . $2;
1952             }
1953              
1954             # \p, \P, \X --> p, P, X
1955             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1956 0         0 $char[$i] = $1;
1957             }
1958              
1959             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1960 0         0 $char[$i] = CORE::chr oct $1;
1961             }
1962             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1963 0         0 $char[$i] = CORE::chr hex $1;
1964             }
1965             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1966 206         848 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1967             }
1968             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1969             $char[$i] = {
1970             '\0' => "\0",
1971             '\n' => "\n",
1972             '\r' => "\r",
1973             '\t' => "\t",
1974             '\f' => "\f",
1975             '\b' => "\x08", # \b means backspace in character class
1976             '\a' => "\a",
1977             '\e' => "\e",
1978             '\d' => '[0-9]',
1979              
1980             # Vertical tabs are now whitespace
1981             # \s in a regex now matches a vertical tab in all circumstances.
1982             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1983             # \t \n \v \f \r space
1984             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1985             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1986             '\s' => '\s',
1987              
1988             '\w' => '[0-9A-Z_a-z]',
1989             '\D' => '${Egbk::eD}',
1990             '\S' => '${Egbk::eS}',
1991             '\W' => '${Egbk::eW}',
1992              
1993             '\H' => '${Egbk::eH}',
1994             '\V' => '${Egbk::eV}',
1995             '\h' => '[\x09\x20]',
1996             '\v' => '[\x0A\x0B\x0C\x0D]',
1997             '\R' => '${Egbk::eR}',
1998              
1999 0         0 }->{$1};
2000             }
2001              
2002             # POSIX-style character classes
2003             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
2004             $char[$i] = {
2005              
2006             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
2007             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
2008             '[:^lower:]' => '${Egbk::not_lower_i}',
2009             '[:^upper:]' => '${Egbk::not_upper_i}',
2010              
2011 33         492 }->{$1};
2012             }
2013             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
2014             $char[$i] = {
2015              
2016             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
2017             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
2018             '[:ascii:]' => '[\x00-\x7F]',
2019             '[:blank:]' => '[\x09\x20]',
2020             '[:cntrl:]' => '[\x00-\x1F\x7F]',
2021             '[:digit:]' => '[\x30-\x39]',
2022             '[:graph:]' => '[\x21-\x7F]',
2023             '[:lower:]' => '[\x61-\x7A]',
2024             '[:print:]' => '[\x20-\x7F]',
2025             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
2026              
2027             # P.174 POSIX-Style Character Classes
2028             # in Chapter 5: Pattern Matching
2029             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2030              
2031             # P.311 11.2.4 Character Classes and other Special Escapes
2032             # in Chapter 11: perlre: Perl regular expressions
2033             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2034              
2035             # P.210 POSIX-Style Character Classes
2036             # in Chapter 5: Pattern Matching
2037             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2038              
2039             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
2040              
2041             '[:upper:]' => '[\x41-\x5A]',
2042             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
2043             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
2044             '[:^alnum:]' => '${Egbk::not_alnum}',
2045             '[:^alpha:]' => '${Egbk::not_alpha}',
2046             '[:^ascii:]' => '${Egbk::not_ascii}',
2047             '[:^blank:]' => '${Egbk::not_blank}',
2048             '[:^cntrl:]' => '${Egbk::not_cntrl}',
2049             '[:^digit:]' => '${Egbk::not_digit}',
2050             '[:^graph:]' => '${Egbk::not_graph}',
2051             '[:^lower:]' => '${Egbk::not_lower}',
2052             '[:^print:]' => '${Egbk::not_print}',
2053             '[:^punct:]' => '${Egbk::not_punct}',
2054             '[:^space:]' => '${Egbk::not_space}',
2055             '[:^upper:]' => '${Egbk::not_upper}',
2056             '[:^word:]' => '${Egbk::not_word}',
2057             '[:^xdigit:]' => '${Egbk::not_xdigit}',
2058              
2059 8         61 }->{$1};
2060             }
2061             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
2062 70         1193 $char[$i] = $1;
2063             }
2064             }
2065              
2066             # open character list
2067 7         32 my @singleoctet = ();
2068 758         1285 my @multipleoctet = ();
2069 758         1023 for (my $i=0; $i <= $#char; ) {
2070              
2071             # escaped -
2072 758 100 100     1730 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
2073 2151         8597 $i += 1;
2074 497         627 next;
2075             }
2076              
2077             # make range regexp
2078             elsif ($char[$i] eq '...') {
2079              
2080             # range error
2081 497 50       936 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    100          
2082 497         1767 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2083             }
2084             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
2085 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
2086 477         1033 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2087             }
2088             }
2089              
2090             # make range regexp per length
2091 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
2092 497         1262 my @regexp = ();
2093              
2094             # is first and last
2095 517 100 100     712 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    100 33        
    50          
    50          
2096 517         1796 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
2097             }
2098              
2099             # is first
2100             elsif ($length == CORE::length($char[$i-1])) {
2101 477         1246 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
2102             }
2103              
2104             # is inside in first and last
2105             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
2106 20         75 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
2107             }
2108              
2109             # is last
2110             elsif ($length == CORE::length($char[$i+1])) {
2111 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
2112             }
2113              
2114             else {
2115 20         112 die __FILE__, ": subroutine make_regexp panic.\n";
2116             }
2117              
2118 0 100       0 if ($length == 1) {
2119 517         1048 push @singleoctet, @regexp;
2120             }
2121             else {
2122 386         870 push @multipleoctet, @regexp;
2123             }
2124             }
2125              
2126 131         315 $i += 2;
2127             }
2128              
2129             # with /i modifier
2130             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
2131 497 100       1067 if ($modifier =~ /i/oxms) {
2132 764         1277 my $uc = Egbk::uc($char[$i]);
2133 192         349 my $fc = Egbk::fc($char[$i]);
2134 192 50       364 if ($uc ne $fc) {
2135 192 50       299 if (CORE::length($fc) == 1) {
2136 192         256 push @singleoctet, $uc, $fc;
2137             }
2138             else {
2139 192         346 push @singleoctet, $uc;
2140 0         0 push @multipleoctet, $fc;
2141             }
2142             }
2143             else {
2144 0         0 push @singleoctet, $char[$i];
2145             }
2146             }
2147             else {
2148 0         0 push @singleoctet, $char[$i];
2149             }
2150 572         875 $i += 1;
2151             }
2152              
2153             # single character of single octet code
2154             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
2155 764         1220 push @singleoctet, "\t", "\x20";
2156 0         0 $i += 1;
2157             }
2158             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
2159 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
2160 0         0 $i += 1;
2161             }
2162             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
2163 0         0 push @singleoctet, $char[$i];
2164 2         6 $i += 1;
2165             }
2166              
2167             # single character of multiple-octet code
2168             else {
2169 2         6 push @multipleoctet, $char[$i];
2170 391         668 $i += 1;
2171             }
2172             }
2173              
2174             # quote metachar
2175 391         657 for (@singleoctet) {
2176 758 50       1592 if ($_ eq '...') {
    100          
    100          
    100          
    100          
2177 1364         5720 $_ = '-';
2178             }
2179             elsif (/\A \n \z/oxms) {
2180 0         0 $_ = '\n';
2181             }
2182             elsif (/\A \r \z/oxms) {
2183 8         19 $_ = '\r';
2184             }
2185             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
2186 8         25 $_ = sprintf('\x%02X', CORE::ord $1);
2187             }
2188             elsif (/\A [\x00-\xFF] \z/oxms) {
2189 1         6 $_ = quotemeta $_;
2190             }
2191             }
2192 939         1362 for (@multipleoctet) {
2193 758 100       1316 if (/\A ([\x80-\xFF].*) ([\x00-\xFF]) \z/oxms) {
2194 693         1759 $_ = $1 . quotemeta $2;
2195             }
2196             }
2197              
2198             # return character list
2199 307         692 return \@singleoctet, \@multipleoctet;
2200             }
2201              
2202             #
2203             # GBK octal escape sequence
2204             #
2205             sub octchr {
2206 758     5 0 2696 my($octdigit) = @_;
2207              
2208 5         14 my @binary = ();
2209 5         10 for my $octal (split(//,$octdigit)) {
2210             push @binary, {
2211             '0' => '000',
2212             '1' => '001',
2213             '2' => '010',
2214             '3' => '011',
2215             '4' => '100',
2216             '5' => '101',
2217             '6' => '110',
2218             '7' => '111',
2219 5         23 }->{$octal};
2220             }
2221 50         177 my $binary = join '', @binary;
2222              
2223             my $octchr = {
2224             # 1234567
2225             1 => pack('B*', "0000000$binary"),
2226             2 => pack('B*', "000000$binary"),
2227             3 => pack('B*', "00000$binary"),
2228             4 => pack('B*', "0000$binary"),
2229             5 => pack('B*', "000$binary"),
2230             6 => pack('B*', "00$binary"),
2231             7 => pack('B*', "0$binary"),
2232             0 => pack('B*', "$binary"),
2233              
2234 5         15 }->{CORE::length($binary) % 8};
2235              
2236 5         64 return $octchr;
2237             }
2238              
2239             #
2240             # GBK hexadecimal escape sequence
2241             #
2242             sub hexchr {
2243 5     5 0 16 my($hexdigit) = @_;
2244              
2245             my $hexchr = {
2246             1 => pack('H*', "0$hexdigit"),
2247             0 => pack('H*', "$hexdigit"),
2248              
2249 5         13 }->{CORE::length($_[0]) % 2};
2250              
2251 5         38 return $hexchr;
2252             }
2253              
2254             #
2255             # GBK open character list for qr
2256             #
2257             sub charlist_qr {
2258              
2259 5     519 0 16 my $modifier = pop @_;
2260 519         985 my @char = @_;
2261              
2262 519         1268 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2263 519         1522 my @singleoctet = @$singleoctet;
2264 519         1072 my @multipleoctet = @$multipleoctet;
2265              
2266             # return character list
2267 519 100       858 if (scalar(@singleoctet) >= 1) {
2268              
2269             # with /i modifier
2270 519 100       1255 if ($modifier =~ m/i/oxms) {
2271 384         895 my %singleoctet_ignorecase = ();
2272 107         159 for (@singleoctet) {
2273 107   100     158 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2274 272         885 for my $ord (hex($1) .. hex($2)) {
2275 80         296 my $char = CORE::chr($ord);
2276 1046         1371 my $uc = Egbk::uc($char);
2277 1046         1274 my $fc = Egbk::fc($char);
2278 1046 100       1478 if ($uc eq $fc) {
2279 1046         1540 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2280             }
2281             else {
2282 457 50       988 if (CORE::length($fc) == 1) {
2283 589         704 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2284 589         1106 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2285             }
2286             else {
2287 589         1367 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2288 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2289             }
2290             }
2291             }
2292             }
2293 0 100       0 if ($_ ne '') {
2294 272         424 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2295             }
2296             }
2297 192         457 my $i = 0;
2298 107         139 my @singleoctet_ignorecase = ();
2299 107         148 for my $ord (0 .. 255) {
2300 107 100       182 if (exists $singleoctet_ignorecase{$ord}) {
2301 27392         29997 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1357  
2302             }
2303             else {
2304 1577         2440 $i++;
2305             }
2306             }
2307 25815         24907 @singleoctet = ();
2308 107         199 for my $range (@singleoctet_ignorecase) {
2309 107 100       243 if (ref $range) {
2310 11412 100       16849 if (scalar(@{$range}) == 1) {
  214 50       210  
2311 214         308 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         6  
2312             }
2313 5         53 elsif (scalar(@{$range}) == 2) {
2314 209         335 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2315             }
2316             else {
2317 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         242  
  209         234  
2318             }
2319             }
2320             }
2321             }
2322              
2323 209         920 my $not_anchor = '';
2324 384         591 $not_anchor = '(?![\x81-\xFE])';
2325              
2326 384         615 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2327             }
2328 384 100       1135 if (scalar(@multipleoctet) >= 2) {
2329 519         1427 return '(?:' . join('|', @multipleoctet) . ')';
2330             }
2331             else {
2332 131         804 return $multipleoctet[0];
2333             }
2334             }
2335              
2336             #
2337             # GBK open character list for not qr
2338             #
2339             sub charlist_not_qr {
2340              
2341 388     239 0 1622 my $modifier = pop @_;
2342 239         393 my @char = @_;
2343              
2344 239         565 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2345 239         521 my @singleoctet = @$singleoctet;
2346 239         505 my @multipleoctet = @$multipleoctet;
2347              
2348             # with /i modifier
2349 239 100       384 if ($modifier =~ m/i/oxms) {
2350 239         559 my %singleoctet_ignorecase = ();
2351 128         179 for (@singleoctet) {
2352 128   100     188 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2353 272         838 for my $ord (hex($1) .. hex($2)) {
2354 80         284 my $char = CORE::chr($ord);
2355 1046         1394 my $uc = Egbk::uc($char);
2356 1046         1260 my $fc = Egbk::fc($char);
2357 1046 100       1457 if ($uc eq $fc) {
2358 1046         1439 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2359             }
2360             else {
2361 457 50       973 if (CORE::length($fc) == 1) {
2362 589         704 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2363 589         1085 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2364             }
2365             else {
2366 589         1424 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2367 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2368             }
2369             }
2370             }
2371             }
2372 0 100       0 if ($_ ne '') {
2373 272         411 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2374             }
2375             }
2376 192         410 my $i = 0;
2377 128         140 my @singleoctet_ignorecase = ();
2378 128         171 for my $ord (0 .. 255) {
2379 128 100       192 if (exists $singleoctet_ignorecase{$ord}) {
2380 32768         36381 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1377  
2381             }
2382             else {
2383 1577         2396 $i++;
2384             }
2385             }
2386 31191         30876 @singleoctet = ();
2387 128         171 for my $range (@singleoctet_ignorecase) {
2388 128 100       269 if (ref $range) {
2389 11412 100       17085 if (scalar(@{$range}) == 1) {
  214 50       195  
2390 214         328 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         10  
2391             }
2392 5         54 elsif (scalar(@{$range}) == 2) {
2393 209         278 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2394             }
2395             else {
2396 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         283  
  209         242  
2397             }
2398             }
2399             }
2400             }
2401              
2402             # return character list
2403 209 100       874 if (scalar(@multipleoctet) >= 1) {
2404 239 100       488 if (scalar(@singleoctet) >= 1) {
2405              
2406             # any character other than multiple-octet and single octet character class
2407 114         181 return '(?!' . join('|', @multipleoctet) . ')(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2408             }
2409             else {
2410              
2411             # any character other than multiple-octet character class
2412 70         509 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2413             }
2414             }
2415             else {
2416 44 50       259 if (scalar(@singleoctet) >= 1) {
2417              
2418             # any character other than single octet character class
2419 125         276 return '(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2420             }
2421             else {
2422              
2423             # any character
2424 125         687 return "(?:$your_char)";
2425             }
2426             }
2427             }
2428              
2429             #
2430             # open file in read mode
2431             #
2432             sub _open_r {
2433 0     768   0 my(undef,$file) = @_;
2434 389     389   5249 use Fcntl qw(O_RDONLY);
  389         3903  
  389         57179  
2435 768         2429 return CORE::sysopen($_[0], $file, &O_RDONLY);
2436             }
2437              
2438             #
2439             # open file in append mode
2440             #
2441             sub _open_a {
2442 768     384   32052 my(undef,$file) = @_;
2443 389     389   7529 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  389         2461  
  389         5961449  
2444 384         1120 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2445             }
2446              
2447             #
2448             # safe system
2449             #
2450             sub _systemx {
2451              
2452             # P.707 29.2.33. exec
2453             # in Chapter 29: Functions
2454             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2455             #
2456             # Be aware that in older releases of Perl, exec (and system) did not flush
2457             # your output buffer, so you needed to enable command buffering by setting $|
2458             # on one or more filehandles to avoid lost output in the case of exec, or
2459             # misordererd output in the case of system. This situation was largely remedied
2460             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2461              
2462             # P.855 exec
2463             # in Chapter 27: Functions
2464             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2465             #
2466             # In very old release of Perl (before v5.6), exec (and system) did not flush
2467             # your output buffer, so you needed to enable command buffering by setting $|
2468             # on one or more filehandles to avoid lost output with exec or misordered
2469             # output with system.
2470              
2471 384     384   91254 $| = 1;
2472              
2473             # P.565 23.1.2. Cleaning Up Your Environment
2474             # in Chapter 23: Security
2475             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2476              
2477             # P.656 Cleaning Up Your Environment
2478             # in Chapter 20: Security
2479             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2480              
2481             # local $ENV{'PATH'} = '.';
2482 384         1425 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2483              
2484             # P.707 29.2.33. exec
2485             # in Chapter 29: Functions
2486             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2487             #
2488             # As we mentioned earlier, exec treats a discrete list of arguments as an
2489             # indication that it should bypass shell processing. However, there is one
2490             # place where you might still get tripped up. The exec call (and system, too)
2491             # will not distinguish between a single scalar argument and an array containing
2492             # only one element.
2493             #
2494             # @args = ("echo surprise"); # just one element in list
2495             # exec @args # still subject to shell escapes
2496             # or die "exec: $!"; # because @args == 1
2497             #
2498             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2499             # first argument as the pathname, which forces the rest of the arguments to be
2500             # interpreted as a list, even if there is only one of them:
2501             #
2502             # exec { $args[0] } @args # safe even with one-argument list
2503             # or die "can't exec @args: $!";
2504              
2505             # P.855 exec
2506             # in Chapter 27: Functions
2507             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2508             #
2509             # As we mentioned earlier, exec treats a discrete list of arguments as a
2510             # directive to bypass shell processing. However, there is one place where
2511             # you might still get tripped up. The exec call (and system, too) cannot
2512             # distinguish between a single scalar argument and an array containing
2513             # only one element.
2514             #
2515             # @args = ("echo surprise"); # just one element in list
2516             # exec @args # still subject to shell escapes
2517             # || die "exec: $!"; # because @args == 1
2518             #
2519             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2520             # argument as the pathname, which forces the rest of the arguments to be
2521             # interpreted as a list, even if there is only one of them:
2522             #
2523             # exec { $args[0] } @args # safe even with one-argument list
2524             # || die "can't exec @args: $!";
2525              
2526 384         3774 return CORE::system { $_[0] } @_; # safe even with one-argument list
  384         925  
2527             }
2528              
2529             #
2530             # GBK order to character (with parameter)
2531             #
2532             sub Egbk::chr(;$) {
2533              
2534 384 0   0 0 47786305 my $c = @_ ? $_[0] : $_;
2535              
2536 0 0       0 if ($c == 0x00) {
2537 0         0 return "\x00";
2538             }
2539             else {
2540 0         0 my @chr = ();
2541 0         0 while ($c > 0) {
2542 0         0 unshift @chr, ($c % 0x100);
2543 0         0 $c = int($c / 0x100);
2544             }
2545 0         0 return pack 'C*', @chr;
2546             }
2547             }
2548              
2549             #
2550             # GBK order to character (without parameter)
2551             #
2552             sub Egbk::chr_() {
2553              
2554 0     0 0 0 my $c = $_;
2555              
2556 0 0       0 if ($c == 0x00) {
2557 0         0 return "\x00";
2558             }
2559             else {
2560 0         0 my @chr = ();
2561 0         0 while ($c > 0) {
2562 0         0 unshift @chr, ($c % 0x100);
2563 0         0 $c = int($c / 0x100);
2564             }
2565 0         0 return pack 'C*', @chr;
2566             }
2567             }
2568              
2569             #
2570             # GBK stacked file test expr
2571             #
2572             sub Egbk::filetest {
2573              
2574 0     0 0 0 my $file = pop @_;
2575 0         0 my $filetest = substr(pop @_, 1);
2576              
2577 0 0       0 unless (CORE::eval qq{Egbk::$filetest(\$file)}) {
2578 0         0 return '';
2579             }
2580 0         0 for my $filetest (CORE::reverse @_) {
2581 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
2582 0         0 return '';
2583             }
2584             }
2585 0         0 return 1;
2586             }
2587              
2588             #
2589             # GBK file test -r expr
2590             #
2591             sub Egbk::r(;*@) {
2592              
2593 0 0   0 0 0 local $_ = shift if @_;
2594 0 0 0     0 croak 'Too many arguments for -r (Egbk::r)' if @_ and not wantarray;
2595              
2596 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2597 0 0       0 return wantarray ? (-r _,@_) : -r _;
2598             }
2599              
2600             # P.908 32.39. Symbol
2601             # in Chapter 32: Standard Modules
2602             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2603              
2604             # P.326 Prototypes
2605             # in Chapter 7: Subroutines
2606             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2607              
2608             # (and so on)
2609              
2610             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2611 0 0       0 return wantarray ? (-r $fh,@_) : -r $fh;
2612             }
2613             elsif (-e $_) {
2614 0 0       0 return wantarray ? (-r _,@_) : -r _;
2615             }
2616             elsif (_MSWin32_5Cended_path($_)) {
2617 0 0       0 if (-d "$_/.") {
2618 0 0       0 return wantarray ? (-r _,@_) : -r _;
2619             }
2620             else {
2621              
2622             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Egbk::*()
2623             # on Windows opens the file for the path which has 5c at end.
2624             # (and so on)
2625              
2626 0         0 my $fh = gensym();
2627 0 0       0 if (_open_r($fh, $_)) {
2628 0         0 my $r = -r $fh;
2629 0 0       0 close($fh) or die "Can't close file: $_: $!";
2630 0 0       0 return wantarray ? ($r,@_) : $r;
2631             }
2632             }
2633             }
2634 0 0       0 return wantarray ? (undef,@_) : undef;
2635             }
2636              
2637             #
2638             # GBK file test -w expr
2639             #
2640             sub Egbk::w(;*@) {
2641              
2642 0 0   0 0 0 local $_ = shift if @_;
2643 0 0 0     0 croak 'Too many arguments for -w (Egbk::w)' if @_ and not wantarray;
2644              
2645 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2646 0 0       0 return wantarray ? (-w _,@_) : -w _;
2647             }
2648             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2649 0 0       0 return wantarray ? (-w $fh,@_) : -w $fh;
2650             }
2651             elsif (-e $_) {
2652 0 0       0 return wantarray ? (-w _,@_) : -w _;
2653             }
2654             elsif (_MSWin32_5Cended_path($_)) {
2655 0 0       0 if (-d "$_/.") {
2656 0 0       0 return wantarray ? (-w _,@_) : -w _;
2657             }
2658             else {
2659 0         0 my $fh = gensym();
2660 0 0       0 if (_open_a($fh, $_)) {
2661 0         0 my $w = -w $fh;
2662 0 0       0 close($fh) or die "Can't close file: $_: $!";
2663 0 0       0 return wantarray ? ($w,@_) : $w;
2664             }
2665             }
2666             }
2667 0 0       0 return wantarray ? (undef,@_) : undef;
2668             }
2669              
2670             #
2671             # GBK file test -x expr
2672             #
2673             sub Egbk::x(;*@) {
2674              
2675 0 0   0 0 0 local $_ = shift if @_;
2676 0 0 0     0 croak 'Too many arguments for -x (Egbk::x)' if @_ and not wantarray;
2677              
2678 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2679 0 0       0 return wantarray ? (-x _,@_) : -x _;
2680             }
2681             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2682 0 0       0 return wantarray ? (-x $fh,@_) : -x $fh;
2683             }
2684             elsif (-e $_) {
2685 0 0       0 return wantarray ? (-x _,@_) : -x _;
2686             }
2687             elsif (_MSWin32_5Cended_path($_)) {
2688 0 0       0 if (-d "$_/.") {
2689 0 0       0 return wantarray ? (-x _,@_) : -x _;
2690             }
2691             else {
2692 0         0 my $fh = gensym();
2693 0 0       0 if (_open_r($fh, $_)) {
2694 0         0 my $dummy_for_underline_cache = -x $fh;
2695 0 0       0 close($fh) or die "Can't close file: $_: $!";
2696             }
2697              
2698             # filename is not .COM .EXE .BAT .CMD
2699 0 0       0 return wantarray ? ('',@_) : '';
2700             }
2701             }
2702 0 0       0 return wantarray ? (undef,@_) : undef;
2703             }
2704              
2705             #
2706             # GBK file test -o expr
2707             #
2708             sub Egbk::o(;*@) {
2709              
2710 0 0   0 0 0 local $_ = shift if @_;
2711 0 0 0     0 croak 'Too many arguments for -o (Egbk::o)' if @_ and not wantarray;
2712              
2713 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2714 0 0       0 return wantarray ? (-o _,@_) : -o _;
2715             }
2716             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2717 0 0       0 return wantarray ? (-o $fh,@_) : -o $fh;
2718             }
2719             elsif (-e $_) {
2720 0 0       0 return wantarray ? (-o _,@_) : -o _;
2721             }
2722             elsif (_MSWin32_5Cended_path($_)) {
2723 0 0       0 if (-d "$_/.") {
2724 0 0       0 return wantarray ? (-o _,@_) : -o _;
2725             }
2726             else {
2727 0         0 my $fh = gensym();
2728 0 0       0 if (_open_r($fh, $_)) {
2729 0         0 my $o = -o $fh;
2730 0 0       0 close($fh) or die "Can't close file: $_: $!";
2731 0 0       0 return wantarray ? ($o,@_) : $o;
2732             }
2733             }
2734             }
2735 0 0       0 return wantarray ? (undef,@_) : undef;
2736             }
2737              
2738             #
2739             # GBK file test -R expr
2740             #
2741             sub Egbk::R(;*@) {
2742              
2743 0 0   0 0 0 local $_ = shift if @_;
2744 0 0 0     0 croak 'Too many arguments for -R (Egbk::R)' if @_ and not wantarray;
2745              
2746 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2747 0 0       0 return wantarray ? (-R _,@_) : -R _;
2748             }
2749             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2750 0 0       0 return wantarray ? (-R $fh,@_) : -R $fh;
2751             }
2752             elsif (-e $_) {
2753 0 0       0 return wantarray ? (-R _,@_) : -R _;
2754             }
2755             elsif (_MSWin32_5Cended_path($_)) {
2756 0 0       0 if (-d "$_/.") {
2757 0 0       0 return wantarray ? (-R _,@_) : -R _;
2758             }
2759             else {
2760 0         0 my $fh = gensym();
2761 0 0       0 if (_open_r($fh, $_)) {
2762 0         0 my $R = -R $fh;
2763 0 0       0 close($fh) or die "Can't close file: $_: $!";
2764 0 0       0 return wantarray ? ($R,@_) : $R;
2765             }
2766             }
2767             }
2768 0 0       0 return wantarray ? (undef,@_) : undef;
2769             }
2770              
2771             #
2772             # GBK file test -W expr
2773             #
2774             sub Egbk::W(;*@) {
2775              
2776 0 0   0 0 0 local $_ = shift if @_;
2777 0 0 0     0 croak 'Too many arguments for -W (Egbk::W)' if @_ and not wantarray;
2778              
2779 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2780 0 0       0 return wantarray ? (-W _,@_) : -W _;
2781             }
2782             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2783 0 0       0 return wantarray ? (-W $fh,@_) : -W $fh;
2784             }
2785             elsif (-e $_) {
2786 0 0       0 return wantarray ? (-W _,@_) : -W _;
2787             }
2788             elsif (_MSWin32_5Cended_path($_)) {
2789 0 0       0 if (-d "$_/.") {
2790 0 0       0 return wantarray ? (-W _,@_) : -W _;
2791             }
2792             else {
2793 0         0 my $fh = gensym();
2794 0 0       0 if (_open_a($fh, $_)) {
2795 0         0 my $W = -W $fh;
2796 0 0       0 close($fh) or die "Can't close file: $_: $!";
2797 0 0       0 return wantarray ? ($W,@_) : $W;
2798             }
2799             }
2800             }
2801 0 0       0 return wantarray ? (undef,@_) : undef;
2802             }
2803              
2804             #
2805             # GBK file test -X expr
2806             #
2807             sub Egbk::X(;*@) {
2808              
2809 0 0   0 1 0 local $_ = shift if @_;
2810 0 0 0     0 croak 'Too many arguments for -X (Egbk::X)' if @_ and not wantarray;
2811              
2812 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2813 0 0       0 return wantarray ? (-X _,@_) : -X _;
2814             }
2815             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2816 0 0       0 return wantarray ? (-X $fh,@_) : -X $fh;
2817             }
2818             elsif (-e $_) {
2819 0 0       0 return wantarray ? (-X _,@_) : -X _;
2820             }
2821             elsif (_MSWin32_5Cended_path($_)) {
2822 0 0       0 if (-d "$_/.") {
2823 0 0       0 return wantarray ? (-X _,@_) : -X _;
2824             }
2825             else {
2826 0         0 my $fh = gensym();
2827 0 0       0 if (_open_r($fh, $_)) {
2828 0         0 my $dummy_for_underline_cache = -X $fh;
2829 0 0       0 close($fh) or die "Can't close file: $_: $!";
2830             }
2831              
2832             # filename is not .COM .EXE .BAT .CMD
2833 0 0       0 return wantarray ? ('',@_) : '';
2834             }
2835             }
2836 0 0       0 return wantarray ? (undef,@_) : undef;
2837             }
2838              
2839             #
2840             # GBK file test -O expr
2841             #
2842             sub Egbk::O(;*@) {
2843              
2844 0 0   0 0 0 local $_ = shift if @_;
2845 0 0 0     0 croak 'Too many arguments for -O (Egbk::O)' if @_ and not wantarray;
2846              
2847 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2848 0 0       0 return wantarray ? (-O _,@_) : -O _;
2849             }
2850             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2851 0 0       0 return wantarray ? (-O $fh,@_) : -O $fh;
2852             }
2853             elsif (-e $_) {
2854 0 0       0 return wantarray ? (-O _,@_) : -O _;
2855             }
2856             elsif (_MSWin32_5Cended_path($_)) {
2857 0 0       0 if (-d "$_/.") {
2858 0 0       0 return wantarray ? (-O _,@_) : -O _;
2859             }
2860             else {
2861 0         0 my $fh = gensym();
2862 0 0       0 if (_open_r($fh, $_)) {
2863 0         0 my $O = -O $fh;
2864 0 0       0 close($fh) or die "Can't close file: $_: $!";
2865 0 0       0 return wantarray ? ($O,@_) : $O;
2866             }
2867             }
2868             }
2869 0 0       0 return wantarray ? (undef,@_) : undef;
2870             }
2871              
2872             #
2873             # GBK file test -e expr
2874             #
2875             sub Egbk::e(;*@) {
2876              
2877 0 50   768 0 0 local $_ = shift if @_;
2878 768 50 33     3378 croak 'Too many arguments for -e (Egbk::e)' if @_ and not wantarray;
2879              
2880 768         2916 local $^W = 0;
2881              
2882 768         2494 my $fh = qualify_to_ref $_;
2883 768 50       2192 if ($_ eq '_') {
    50          
    50          
    50          
    50          
2884 768 0       3460 return wantarray ? (-e _,@_) : -e _;
2885             }
2886              
2887             # return false if directory handle
2888             elsif (defined Egbk::telldir($fh)) {
2889 0 0       0 return wantarray ? ('',@_) : '';
2890             }
2891              
2892             # return true if file handle
2893             elsif (defined fileno $fh) {
2894 0 0       0 return wantarray ? (1,@_) : 1;
2895             }
2896              
2897             elsif (-e $_) {
2898 0 0       0 return wantarray ? (1,@_) : 1;
2899             }
2900             elsif (_MSWin32_5Cended_path($_)) {
2901 0 0       0 if (-d "$_/.") {
2902 0 0       0 return wantarray ? (1,@_) : 1;
2903             }
2904             else {
2905 0         0 my $fh = gensym();
2906 0 0       0 if (_open_r($fh, $_)) {
2907 0         0 my $e = -e $fh;
2908 0 0       0 close($fh) or die "Can't close file: $_: $!";
2909 0 0       0 return wantarray ? ($e,@_) : $e;
2910             }
2911             }
2912             }
2913 0 50       0 return wantarray ? (undef,@_) : undef;
2914             }
2915              
2916             #
2917             # GBK file test -z expr
2918             #
2919             sub Egbk::z(;*@) {
2920              
2921 768 0   0 0 4040 local $_ = shift if @_;
2922 0 0 0     0 croak 'Too many arguments for -z (Egbk::z)' if @_ and not wantarray;
2923              
2924 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2925 0 0       0 return wantarray ? (-z _,@_) : -z _;
2926             }
2927             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2928 0 0       0 return wantarray ? (-z $fh,@_) : -z $fh;
2929             }
2930             elsif (-e $_) {
2931 0 0       0 return wantarray ? (-z _,@_) : -z _;
2932             }
2933             elsif (_MSWin32_5Cended_path($_)) {
2934 0 0       0 if (-d "$_/.") {
2935 0 0       0 return wantarray ? (-z _,@_) : -z _;
2936             }
2937             else {
2938 0         0 my $fh = gensym();
2939 0 0       0 if (_open_r($fh, $_)) {
2940 0         0 my $z = -z $fh;
2941 0 0       0 close($fh) or die "Can't close file: $_: $!";
2942 0 0       0 return wantarray ? ($z,@_) : $z;
2943             }
2944             }
2945             }
2946 0 0       0 return wantarray ? (undef,@_) : undef;
2947             }
2948              
2949             #
2950             # GBK file test -s expr
2951             #
2952             sub Egbk::s(;*@) {
2953              
2954 0 0   0 0 0 local $_ = shift if @_;
2955 0 0 0     0 croak 'Too many arguments for -s (Egbk::s)' if @_ and not wantarray;
2956              
2957 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2958 0 0       0 return wantarray ? (-s _,@_) : -s _;
2959             }
2960             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2961 0 0       0 return wantarray ? (-s $fh,@_) : -s $fh;
2962             }
2963             elsif (-e $_) {
2964 0 0       0 return wantarray ? (-s _,@_) : -s _;
2965             }
2966             elsif (_MSWin32_5Cended_path($_)) {
2967 0 0       0 if (-d "$_/.") {
2968 0 0       0 return wantarray ? (-s _,@_) : -s _;
2969             }
2970             else {
2971 0         0 my $fh = gensym();
2972 0 0       0 if (_open_r($fh, $_)) {
2973 0         0 my $s = -s $fh;
2974 0 0       0 close($fh) or die "Can't close file: $_: $!";
2975 0 0       0 return wantarray ? ($s,@_) : $s;
2976             }
2977             }
2978             }
2979 0 0       0 return wantarray ? (undef,@_) : undef;
2980             }
2981              
2982             #
2983             # GBK file test -f expr
2984             #
2985             sub Egbk::f(;*@) {
2986              
2987 0 0   0 0 0 local $_ = shift if @_;
2988 0 0 0     0 croak 'Too many arguments for -f (Egbk::f)' if @_ and not wantarray;
2989              
2990 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2991 0 0       0 return wantarray ? (-f _,@_) : -f _;
2992             }
2993             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2994 0 0       0 return wantarray ? (-f $fh,@_) : -f $fh;
2995             }
2996             elsif (-e $_) {
2997 0 0       0 return wantarray ? (-f _,@_) : -f _;
2998             }
2999             elsif (_MSWin32_5Cended_path($_)) {
3000 0 0       0 if (-d "$_/.") {
3001 0 0       0 return wantarray ? ('',@_) : '';
3002             }
3003             else {
3004 0         0 my $fh = gensym();
3005 0 0       0 if (_open_r($fh, $_)) {
3006 0         0 my $f = -f $fh;
3007 0 0       0 close($fh) or die "Can't close file: $_: $!";
3008 0 0       0 return wantarray ? ($f,@_) : $f;
3009             }
3010             }
3011             }
3012 0 0       0 return wantarray ? (undef,@_) : undef;
3013             }
3014              
3015             #
3016             # GBK file test -d expr
3017             #
3018             sub Egbk::d(;*@) {
3019              
3020 0 0   0 0 0 local $_ = shift if @_;
3021 0 0 0     0 croak 'Too many arguments for -d (Egbk::d)' if @_ and not wantarray;
3022              
3023 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3024 0 0       0 return wantarray ? (-d _,@_) : -d _;
3025             }
3026              
3027             # return false if file handle or directory handle
3028             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3029 0 0       0 return wantarray ? ('',@_) : '';
3030             }
3031             elsif (-e $_) {
3032 0 0       0 return wantarray ? (-d _,@_) : -d _;
3033             }
3034             elsif (_MSWin32_5Cended_path($_)) {
3035 0 0       0 return wantarray ? (-d "$_/.",@_) : -d "$_/.";
3036             }
3037 0 0       0 return wantarray ? (undef,@_) : undef;
3038             }
3039              
3040             #
3041             # GBK file test -l expr
3042             #
3043             sub Egbk::l(;*@) {
3044              
3045 0 0   0 0 0 local $_ = shift if @_;
3046 0 0 0     0 croak 'Too many arguments for -l (Egbk::l)' if @_ and not wantarray;
3047              
3048 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3049 0 0       0 return wantarray ? (-l _,@_) : -l _;
3050             }
3051             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3052 0 0       0 return wantarray ? (-l $fh,@_) : -l $fh;
3053             }
3054             elsif (-e $_) {
3055 0 0       0 return wantarray ? (-l _,@_) : -l _;
3056             }
3057             elsif (_MSWin32_5Cended_path($_)) {
3058 0 0       0 if (-d "$_/.") {
3059 0 0       0 return wantarray ? (-l _,@_) : -l _;
3060             }
3061             else {
3062 0         0 my $fh = gensym();
3063 0 0       0 if (_open_r($fh, $_)) {
3064 0         0 my $l = -l $fh;
3065 0 0       0 close($fh) or die "Can't close file: $_: $!";
3066 0 0       0 return wantarray ? ($l,@_) : $l;
3067             }
3068             }
3069             }
3070 0 0       0 return wantarray ? (undef,@_) : undef;
3071             }
3072              
3073             #
3074             # GBK file test -p expr
3075             #
3076             sub Egbk::p(;*@) {
3077              
3078 0 0   0 0 0 local $_ = shift if @_;
3079 0 0 0     0 croak 'Too many arguments for -p (Egbk::p)' if @_ and not wantarray;
3080              
3081 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3082 0 0       0 return wantarray ? (-p _,@_) : -p _;
3083             }
3084             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3085 0 0       0 return wantarray ? (-p $fh,@_) : -p $fh;
3086             }
3087             elsif (-e $_) {
3088 0 0       0 return wantarray ? (-p _,@_) : -p _;
3089             }
3090             elsif (_MSWin32_5Cended_path($_)) {
3091 0 0       0 if (-d "$_/.") {
3092 0 0       0 return wantarray ? (-p _,@_) : -p _;
3093             }
3094             else {
3095 0         0 my $fh = gensym();
3096 0 0       0 if (_open_r($fh, $_)) {
3097 0         0 my $p = -p $fh;
3098 0 0       0 close($fh) or die "Can't close file: $_: $!";
3099 0 0       0 return wantarray ? ($p,@_) : $p;
3100             }
3101             }
3102             }
3103 0 0       0 return wantarray ? (undef,@_) : undef;
3104             }
3105              
3106             #
3107             # GBK file test -S expr
3108             #
3109             sub Egbk::S(;*@) {
3110              
3111 0 0   0 0 0 local $_ = shift if @_;
3112 0 0 0     0 croak 'Too many arguments for -S (Egbk::S)' if @_ and not wantarray;
3113              
3114 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3115 0 0       0 return wantarray ? (-S _,@_) : -S _;
3116             }
3117             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3118 0 0       0 return wantarray ? (-S $fh,@_) : -S $fh;
3119             }
3120             elsif (-e $_) {
3121 0 0       0 return wantarray ? (-S _,@_) : -S _;
3122             }
3123             elsif (_MSWin32_5Cended_path($_)) {
3124 0 0       0 if (-d "$_/.") {
3125 0 0       0 return wantarray ? (-S _,@_) : -S _;
3126             }
3127             else {
3128 0         0 my $fh = gensym();
3129 0 0       0 if (_open_r($fh, $_)) {
3130 0         0 my $S = -S $fh;
3131 0 0       0 close($fh) or die "Can't close file: $_: $!";
3132 0 0       0 return wantarray ? ($S,@_) : $S;
3133             }
3134             }
3135             }
3136 0 0       0 return wantarray ? (undef,@_) : undef;
3137             }
3138              
3139             #
3140             # GBK file test -b expr
3141             #
3142             sub Egbk::b(;*@) {
3143              
3144 0 0   0 0 0 local $_ = shift if @_;
3145 0 0 0     0 croak 'Too many arguments for -b (Egbk::b)' if @_ and not wantarray;
3146              
3147 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3148 0 0       0 return wantarray ? (-b _,@_) : -b _;
3149             }
3150             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3151 0 0       0 return wantarray ? (-b $fh,@_) : -b $fh;
3152             }
3153             elsif (-e $_) {
3154 0 0       0 return wantarray ? (-b _,@_) : -b _;
3155             }
3156             elsif (_MSWin32_5Cended_path($_)) {
3157 0 0       0 if (-d "$_/.") {
3158 0 0       0 return wantarray ? (-b _,@_) : -b _;
3159             }
3160             else {
3161 0         0 my $fh = gensym();
3162 0 0       0 if (_open_r($fh, $_)) {
3163 0         0 my $b = -b $fh;
3164 0 0       0 close($fh) or die "Can't close file: $_: $!";
3165 0 0       0 return wantarray ? ($b,@_) : $b;
3166             }
3167             }
3168             }
3169 0 0       0 return wantarray ? (undef,@_) : undef;
3170             }
3171              
3172             #
3173             # GBK file test -c expr
3174             #
3175             sub Egbk::c(;*@) {
3176              
3177 0 0   0 0 0 local $_ = shift if @_;
3178 0 0 0     0 croak 'Too many arguments for -c (Egbk::c)' if @_ and not wantarray;
3179              
3180 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3181 0 0       0 return wantarray ? (-c _,@_) : -c _;
3182             }
3183             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3184 0 0       0 return wantarray ? (-c $fh,@_) : -c $fh;
3185             }
3186             elsif (-e $_) {
3187 0 0       0 return wantarray ? (-c _,@_) : -c _;
3188             }
3189             elsif (_MSWin32_5Cended_path($_)) {
3190 0 0       0 if (-d "$_/.") {
3191 0 0       0 return wantarray ? (-c _,@_) : -c _;
3192             }
3193             else {
3194 0         0 my $fh = gensym();
3195 0 0       0 if (_open_r($fh, $_)) {
3196 0         0 my $c = -c $fh;
3197 0 0       0 close($fh) or die "Can't close file: $_: $!";
3198 0 0       0 return wantarray ? ($c,@_) : $c;
3199             }
3200             }
3201             }
3202 0 0       0 return wantarray ? (undef,@_) : undef;
3203             }
3204              
3205             #
3206             # GBK file test -u expr
3207             #
3208             sub Egbk::u(;*@) {
3209              
3210 0 0   0 0 0 local $_ = shift if @_;
3211 0 0 0     0 croak 'Too many arguments for -u (Egbk::u)' if @_ and not wantarray;
3212              
3213 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3214 0 0       0 return wantarray ? (-u _,@_) : -u _;
3215             }
3216             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3217 0 0       0 return wantarray ? (-u $fh,@_) : -u $fh;
3218             }
3219             elsif (-e $_) {
3220 0 0       0 return wantarray ? (-u _,@_) : -u _;
3221             }
3222             elsif (_MSWin32_5Cended_path($_)) {
3223 0 0       0 if (-d "$_/.") {
3224 0 0       0 return wantarray ? (-u _,@_) : -u _;
3225             }
3226             else {
3227 0         0 my $fh = gensym();
3228 0 0       0 if (_open_r($fh, $_)) {
3229 0         0 my $u = -u $fh;
3230 0 0       0 close($fh) or die "Can't close file: $_: $!";
3231 0 0       0 return wantarray ? ($u,@_) : $u;
3232             }
3233             }
3234             }
3235 0 0       0 return wantarray ? (undef,@_) : undef;
3236             }
3237              
3238             #
3239             # GBK file test -g expr
3240             #
3241             sub Egbk::g(;*@) {
3242              
3243 0 0   0 0 0 local $_ = shift if @_;
3244 0 0 0     0 croak 'Too many arguments for -g (Egbk::g)' if @_ and not wantarray;
3245              
3246 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3247 0 0       0 return wantarray ? (-g _,@_) : -g _;
3248             }
3249             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3250 0 0       0 return wantarray ? (-g $fh,@_) : -g $fh;
3251             }
3252             elsif (-e $_) {
3253 0 0       0 return wantarray ? (-g _,@_) : -g _;
3254             }
3255             elsif (_MSWin32_5Cended_path($_)) {
3256 0 0       0 if (-d "$_/.") {
3257 0 0       0 return wantarray ? (-g _,@_) : -g _;
3258             }
3259             else {
3260 0         0 my $fh = gensym();
3261 0 0       0 if (_open_r($fh, $_)) {
3262 0         0 my $g = -g $fh;
3263 0 0       0 close($fh) or die "Can't close file: $_: $!";
3264 0 0       0 return wantarray ? ($g,@_) : $g;
3265             }
3266             }
3267             }
3268 0 0       0 return wantarray ? (undef,@_) : undef;
3269             }
3270              
3271             #
3272             # GBK file test -k expr
3273             #
3274             sub Egbk::k(;*@) {
3275              
3276 0 0   0 0 0 local $_ = shift if @_;
3277 0 0 0     0 croak 'Too many arguments for -k (Egbk::k)' if @_ and not wantarray;
3278              
3279 0 0       0 if ($_ eq '_') {
    0          
    0          
3280 0 0       0 return wantarray ? ('',@_) : '';
3281             }
3282             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3283 0 0       0 return wantarray ? ('',@_) : '';
3284             }
3285             elsif ($] =~ /^5\.008/oxms) {
3286 0 0       0 return wantarray ? ('',@_) : '';
3287             }
3288 0 0       0 return wantarray ? ($_,@_) : $_;
3289             }
3290              
3291             #
3292             # GBK file test -T expr
3293             #
3294             sub Egbk::T(;*@) {
3295              
3296 0 0   0 0 0 local $_ = shift if @_;
3297              
3298             # Use of croak without parentheses makes die on Strawberry Perl 5.008 and 5.010, like:
3299             # croak 'Too many arguments for -T (Egbk::T)';
3300             # Must be used by parentheses like:
3301             # croak('Too many arguments for -T (Egbk::T)');
3302              
3303 0 0 0     0 if (@_ and not wantarray) {
3304 0         0 croak('Too many arguments for -T (Egbk::T)');
3305             }
3306              
3307 0         0 my $T = 1;
3308              
3309 0         0 my $fh = qualify_to_ref $_;
3310 0 0       0 if (defined fileno $fh) {
3311              
3312 0 0       0 if (defined Egbk::telldir($fh)) {
3313 0 0       0 return wantarray ? (undef,@_) : undef;
3314             }
3315              
3316             # P.813 29.2.176. tell
3317             # in Chapter 29: Functions
3318             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3319              
3320             # P.970 tell
3321             # in Chapter 27: Functions
3322             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3323              
3324             # (and so on)
3325              
3326 0         0 my $systell = sysseek $fh, 0, 1;
3327              
3328 0 0       0 if (sysread $fh, my $block, 512) {
3329              
3330             # P.163 Binary file check in Little Perl Parlor 16
3331             # of Book No. T1008901080816 ZASSHI 08901-8 UNIX MAGAZINE 1993 Aug VOL8#8
3332             # (and so on)
3333              
3334 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3335 0         0 $T = '';
3336             }
3337             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3338 0         0 $T = '';
3339             }
3340             }
3341              
3342             # 0 byte or eof
3343             else {
3344 0         0 $T = 1;
3345             }
3346              
3347 0         0 my $dummy_for_underline_cache = -T $fh;
3348 0         0 sysseek $fh, $systell, 0;
3349             }
3350             else {
3351 0 0 0     0 if (-d $_ or -d "$_/.") {
3352 0 0       0 return wantarray ? (undef,@_) : undef;
3353             }
3354              
3355 0         0 $fh = gensym();
3356 0 0       0 if (_open_r($fh, $_)) {
3357             }
3358             else {
3359 0 0       0 return wantarray ? (undef,@_) : undef;
3360             }
3361 0 0       0 if (sysread $fh, my $block, 512) {
3362 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3363 0         0 $T = '';
3364             }
3365             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3366 0         0 $T = '';
3367             }
3368             }
3369              
3370             # 0 byte or eof
3371             else {
3372 0         0 $T = 1;
3373             }
3374 0         0 my $dummy_for_underline_cache = -T $fh;
3375 0 0       0 close($fh) or die "Can't close file: $_: $!";
3376             }
3377              
3378 0 0       0 return wantarray ? ($T,@_) : $T;
3379             }
3380              
3381             #
3382             # GBK file test -B expr
3383             #
3384             sub Egbk::B(;*@) {
3385              
3386 0 0   0 0 0 local $_ = shift if @_;
3387 0 0 0     0 croak 'Too many arguments for -B (Egbk::B)' if @_ and not wantarray;
3388 0         0 my $B = '';
3389              
3390 0         0 my $fh = qualify_to_ref $_;
3391 0 0       0 if (defined fileno $fh) {
3392              
3393 0 0       0 if (defined Egbk::telldir($fh)) {
3394 0 0       0 return wantarray ? (undef,@_) : undef;
3395             }
3396              
3397 0         0 my $systell = sysseek $fh, 0, 1;
3398              
3399 0 0       0 if (sysread $fh, my $block, 512) {
3400 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3401 0         0 $B = 1;
3402             }
3403             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3404 0         0 $B = 1;
3405             }
3406             }
3407              
3408             # 0 byte or eof
3409             else {
3410 0         0 $B = 1;
3411             }
3412              
3413 0         0 my $dummy_for_underline_cache = -B $fh;
3414 0         0 sysseek $fh, $systell, 0;
3415             }
3416             else {
3417 0 0 0     0 if (-d $_ or -d "$_/.") {
3418 0 0       0 return wantarray ? (undef,@_) : undef;
3419             }
3420              
3421 0         0 $fh = gensym();
3422 0 0       0 if (_open_r($fh, $_)) {
3423             }
3424             else {
3425 0 0       0 return wantarray ? (undef,@_) : undef;
3426             }
3427 0 0       0 if (sysread $fh, my $block, 512) {
3428 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3429 0         0 $B = 1;
3430             }
3431             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3432 0         0 $B = 1;
3433             }
3434             }
3435              
3436             # 0 byte or eof
3437             else {
3438 0         0 $B = 1;
3439             }
3440 0         0 my $dummy_for_underline_cache = -B $fh;
3441 0 0       0 close($fh) or die "Can't close file: $_: $!";
3442             }
3443              
3444 0 0       0 return wantarray ? ($B,@_) : $B;
3445             }
3446              
3447             #
3448             # GBK file test -M expr
3449             #
3450             sub Egbk::M(;*@) {
3451              
3452 0 0   0 0 0 local $_ = shift if @_;
3453 0 0 0     0 croak 'Too many arguments for -M (Egbk::M)' if @_ and not wantarray;
3454              
3455 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3456 0 0       0 return wantarray ? (-M _,@_) : -M _;
3457             }
3458             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3459 0 0       0 return wantarray ? (-M $fh,@_) : -M $fh;
3460             }
3461             elsif (-e $_) {
3462 0 0       0 return wantarray ? (-M _,@_) : -M _;
3463             }
3464             elsif (_MSWin32_5Cended_path($_)) {
3465 0 0       0 if (-d "$_/.") {
3466 0 0       0 return wantarray ? (-M _,@_) : -M _;
3467             }
3468             else {
3469 0         0 my $fh = gensym();
3470 0 0       0 if (_open_r($fh, $_)) {
3471 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3472 0 0       0 close($fh) or die "Can't close file: $_: $!";
3473 0         0 my $M = ($^T - $mtime) / (24*60*60);
3474 0 0       0 return wantarray ? ($M,@_) : $M;
3475             }
3476             }
3477             }
3478 0 0       0 return wantarray ? (undef,@_) : undef;
3479             }
3480              
3481             #
3482             # GBK file test -A expr
3483             #
3484             sub Egbk::A(;*@) {
3485              
3486 0 0   0 0 0 local $_ = shift if @_;
3487 0 0 0     0 croak 'Too many arguments for -A (Egbk::A)' if @_ and not wantarray;
3488              
3489 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3490 0 0       0 return wantarray ? (-A _,@_) : -A _;
3491             }
3492             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3493 0 0       0 return wantarray ? (-A $fh,@_) : -A $fh;
3494             }
3495             elsif (-e $_) {
3496 0 0       0 return wantarray ? (-A _,@_) : -A _;
3497             }
3498             elsif (_MSWin32_5Cended_path($_)) {
3499 0 0       0 if (-d "$_/.") {
3500 0 0       0 return wantarray ? (-A _,@_) : -A _;
3501             }
3502             else {
3503 0         0 my $fh = gensym();
3504 0 0       0 if (_open_r($fh, $_)) {
3505 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3506 0 0       0 close($fh) or die "Can't close file: $_: $!";
3507 0         0 my $A = ($^T - $atime) / (24*60*60);
3508 0 0       0 return wantarray ? ($A,@_) : $A;
3509             }
3510             }
3511             }
3512 0 0       0 return wantarray ? (undef,@_) : undef;
3513             }
3514              
3515             #
3516             # GBK file test -C expr
3517             #
3518             sub Egbk::C(;*@) {
3519              
3520 0 0   0 0 0 local $_ = shift if @_;
3521 0 0 0     0 croak 'Too many arguments for -C (Egbk::C)' if @_ and not wantarray;
3522              
3523 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3524 0 0       0 return wantarray ? (-C _,@_) : -C _;
3525             }
3526             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3527 0 0       0 return wantarray ? (-C $fh,@_) : -C $fh;
3528             }
3529             elsif (-e $_) {
3530 0 0       0 return wantarray ? (-C _,@_) : -C _;
3531             }
3532             elsif (_MSWin32_5Cended_path($_)) {
3533 0 0       0 if (-d "$_/.") {
3534 0 0       0 return wantarray ? (-C _,@_) : -C _;
3535             }
3536             else {
3537 0         0 my $fh = gensym();
3538 0 0       0 if (_open_r($fh, $_)) {
3539 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3540 0 0       0 close($fh) or die "Can't close file: $_: $!";
3541 0         0 my $C = ($^T - $ctime) / (24*60*60);
3542 0 0       0 return wantarray ? ($C,@_) : $C;
3543             }
3544             }
3545             }
3546 0 0       0 return wantarray ? (undef,@_) : undef;
3547             }
3548              
3549             #
3550             # GBK stacked file test $_
3551             #
3552             sub Egbk::filetest_ {
3553              
3554 0     0 0 0 my $filetest = substr(pop @_, 1);
3555              
3556 0 0       0 unless (CORE::eval qq{Egbk::${filetest}_}) {
3557 0         0 return '';
3558             }
3559 0         0 for my $filetest (CORE::reverse @_) {
3560 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
3561 0         0 return '';
3562             }
3563             }
3564 0         0 return 1;
3565             }
3566              
3567             #
3568             # GBK file test -r $_
3569             #
3570             sub Egbk::r_() {
3571              
3572 0 0   0 0 0 if (-e $_) {
    0          
3573 0 0       0 return -r _ ? 1 : '';
3574             }
3575             elsif (_MSWin32_5Cended_path($_)) {
3576 0 0       0 if (-d "$_/.") {
3577 0 0       0 return -r _ ? 1 : '';
3578             }
3579             else {
3580 0         0 my $fh = gensym();
3581 0 0       0 if (_open_r($fh, $_)) {
3582 0         0 my $r = -r $fh;
3583 0 0       0 close($fh) or die "Can't close file: $_: $!";
3584 0 0       0 return $r ? 1 : '';
3585             }
3586             }
3587             }
3588              
3589             # 10.10. Returning Failure
3590             # in Chapter 10. Subroutines
3591             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3592             # (and so on)
3593              
3594             # 2010-01-26 The difference of "return;" and "return undef;"
3595             # http://d.hatena.ne.jp/gfx/20100126/1264474754
3596             #
3597             # "Perl Best Practices" recommends to use "return;"*1 to return nothing, but
3598             # it might be wrong in some cases. If you use this idiom for those functions
3599             # which are expected to return a scalar value, e.g. searching functions, the
3600             # user of those functions will be surprised at what they return in list
3601             # context, an empty list - note that many functions and all the methods
3602             # evaluate their arguments in list context. You'd better to use "return undef;"
3603             # for such scalar functions.
3604             #
3605             # sub search_something {
3606             # my($arg) = @_;
3607             # # search_something...
3608             # if(defined $found){
3609             # return $found;
3610             # }
3611             # return; # XXX: you'd better to "return undef;"
3612             # }
3613             #
3614             # # ...
3615             #
3616             # # you'll get what you want, but ...
3617             # my $something = search_something($source);
3618             #
3619             # # you won't get what you want here.
3620             # # @_ for doit() is (-foo => $opt), not (undef, -foo => $opt).
3621             # $obj->doit(search_something($source), -option=> $optval);
3622             #
3623             # # you have to use the "scalar" operator in such a case.
3624             # $obj->doit(scalar search_something($source), ...);
3625             #
3626             # *1: it returns an empty list in list context, or returns undef in scalar
3627             # context
3628             #
3629             # (and so on)
3630              
3631 0         0 return undef;
3632             }
3633              
3634             #
3635             # GBK file test -w $_
3636             #
3637             sub Egbk::w_() {
3638              
3639 0 0   0 0 0 if (-e $_) {
    0          
3640 0 0       0 return -w _ ? 1 : '';
3641             }
3642             elsif (_MSWin32_5Cended_path($_)) {
3643 0 0       0 if (-d "$_/.") {
3644 0 0       0 return -w _ ? 1 : '';
3645             }
3646             else {
3647 0         0 my $fh = gensym();
3648 0 0       0 if (_open_a($fh, $_)) {
3649 0         0 my $w = -w $fh;
3650 0 0       0 close($fh) or die "Can't close file: $_: $!";
3651 0 0       0 return $w ? 1 : '';
3652             }
3653             }
3654             }
3655 0         0 return undef;
3656             }
3657              
3658             #
3659             # GBK file test -x $_
3660             #
3661             sub Egbk::x_() {
3662              
3663 0 0   0 0 0 if (-e $_) {
    0          
3664 0 0       0 return -x _ ? 1 : '';
3665             }
3666             elsif (_MSWin32_5Cended_path($_)) {
3667 0 0       0 if (-d "$_/.") {
3668 0 0       0 return -x _ ? 1 : '';
3669             }
3670             else {
3671 0         0 my $fh = gensym();
3672 0 0       0 if (_open_r($fh, $_)) {
3673 0         0 my $dummy_for_underline_cache = -x $fh;
3674 0 0       0 close($fh) or die "Can't close file: $_: $!";
3675             }
3676              
3677             # filename is not .COM .EXE .BAT .CMD
3678 0         0 return '';
3679             }
3680             }
3681 0         0 return undef;
3682             }
3683              
3684             #
3685             # GBK file test -o $_
3686             #
3687             sub Egbk::o_() {
3688              
3689 0 0   0 0 0 if (-e $_) {
    0          
3690 0 0       0 return -o _ ? 1 : '';
3691             }
3692             elsif (_MSWin32_5Cended_path($_)) {
3693 0 0       0 if (-d "$_/.") {
3694 0 0       0 return -o _ ? 1 : '';
3695             }
3696             else {
3697 0         0 my $fh = gensym();
3698 0 0       0 if (_open_r($fh, $_)) {
3699 0         0 my $o = -o $fh;
3700 0 0       0 close($fh) or die "Can't close file: $_: $!";
3701 0 0       0 return $o ? 1 : '';
3702             }
3703             }
3704             }
3705 0         0 return undef;
3706             }
3707              
3708             #
3709             # GBK file test -R $_
3710             #
3711             sub Egbk::R_() {
3712              
3713 0 0   0 0 0 if (-e $_) {
    0          
3714 0 0       0 return -R _ ? 1 : '';
3715             }
3716             elsif (_MSWin32_5Cended_path($_)) {
3717 0 0       0 if (-d "$_/.") {
3718 0 0       0 return -R _ ? 1 : '';
3719             }
3720             else {
3721 0         0 my $fh = gensym();
3722 0 0       0 if (_open_r($fh, $_)) {
3723 0         0 my $R = -R $fh;
3724 0 0       0 close($fh) or die "Can't close file: $_: $!";
3725 0 0       0 return $R ? 1 : '';
3726             }
3727             }
3728             }
3729 0         0 return undef;
3730             }
3731              
3732             #
3733             # GBK file test -W $_
3734             #
3735             sub Egbk::W_() {
3736              
3737 0 0   0 0 0 if (-e $_) {
    0          
3738 0 0       0 return -W _ ? 1 : '';
3739             }
3740             elsif (_MSWin32_5Cended_path($_)) {
3741 0 0       0 if (-d "$_/.") {
3742 0 0       0 return -W _ ? 1 : '';
3743             }
3744             else {
3745 0         0 my $fh = gensym();
3746 0 0       0 if (_open_a($fh, $_)) {
3747 0         0 my $W = -W $fh;
3748 0 0       0 close($fh) or die "Can't close file: $_: $!";
3749 0 0       0 return $W ? 1 : '';
3750             }
3751             }
3752             }
3753 0         0 return undef;
3754             }
3755              
3756             #
3757             # GBK file test -X $_
3758             #
3759             sub Egbk::X_() {
3760              
3761 0 0   0 0 0 if (-e $_) {
    0          
3762 0 0       0 return -X _ ? 1 : '';
3763             }
3764             elsif (_MSWin32_5Cended_path($_)) {
3765 0 0       0 if (-d "$_/.") {
3766 0 0       0 return -X _ ? 1 : '';
3767             }
3768             else {
3769 0         0 my $fh = gensym();
3770 0 0       0 if (_open_r($fh, $_)) {
3771 0         0 my $dummy_for_underline_cache = -X $fh;
3772 0 0       0 close($fh) or die "Can't close file: $_: $!";
3773             }
3774              
3775             # filename is not .COM .EXE .BAT .CMD
3776 0         0 return '';
3777             }
3778             }
3779 0         0 return undef;
3780             }
3781              
3782             #
3783             # GBK file test -O $_
3784             #
3785             sub Egbk::O_() {
3786              
3787 0 0   0 0 0 if (-e $_) {
    0          
3788 0 0       0 return -O _ ? 1 : '';
3789             }
3790             elsif (_MSWin32_5Cended_path($_)) {
3791 0 0       0 if (-d "$_/.") {
3792 0 0       0 return -O _ ? 1 : '';
3793             }
3794             else {
3795 0         0 my $fh = gensym();
3796 0 0       0 if (_open_r($fh, $_)) {
3797 0         0 my $O = -O $fh;
3798 0 0       0 close($fh) or die "Can't close file: $_: $!";
3799 0 0       0 return $O ? 1 : '';
3800             }
3801             }
3802             }
3803 0         0 return undef;
3804             }
3805              
3806             #
3807             # GBK file test -e $_
3808             #
3809             sub Egbk::e_() {
3810              
3811 0 0   0 0 0 if (-e $_) {
    0          
3812 0         0 return 1;
3813             }
3814             elsif (_MSWin32_5Cended_path($_)) {
3815 0 0       0 if (-d "$_/.") {
3816 0         0 return 1;
3817             }
3818             else {
3819 0         0 my $fh = gensym();
3820 0 0       0 if (_open_r($fh, $_)) {
3821 0         0 my $e = -e $fh;
3822 0 0       0 close($fh) or die "Can't close file: $_: $!";
3823 0 0       0 return $e ? 1 : '';
3824             }
3825             }
3826             }
3827 0         0 return undef;
3828             }
3829              
3830             #
3831             # GBK file test -z $_
3832             #
3833             sub Egbk::z_() {
3834              
3835 0 0   0 0 0 if (-e $_) {
    0          
3836 0 0       0 return -z _ ? 1 : '';
3837             }
3838             elsif (_MSWin32_5Cended_path($_)) {
3839 0 0       0 if (-d "$_/.") {
3840 0 0       0 return -z _ ? 1 : '';
3841             }
3842             else {
3843 0         0 my $fh = gensym();
3844 0 0       0 if (_open_r($fh, $_)) {
3845 0         0 my $z = -z $fh;
3846 0 0       0 close($fh) or die "Can't close file: $_: $!";
3847 0 0       0 return $z ? 1 : '';
3848             }
3849             }
3850             }
3851 0         0 return undef;
3852             }
3853              
3854             #
3855             # GBK file test -s $_
3856             #
3857             sub Egbk::s_() {
3858              
3859 0 0   0 0 0 if (-e $_) {
    0          
3860 0         0 return -s _;
3861             }
3862             elsif (_MSWin32_5Cended_path($_)) {
3863 0 0       0 if (-d "$_/.") {
3864 0         0 return -s _;
3865             }
3866             else {
3867 0         0 my $fh = gensym();
3868 0 0       0 if (_open_r($fh, $_)) {
3869 0         0 my $s = -s $fh;
3870 0 0       0 close($fh) or die "Can't close file: $_: $!";
3871 0         0 return $s;
3872             }
3873             }
3874             }
3875 0         0 return undef;
3876             }
3877              
3878             #
3879             # GBK file test -f $_
3880             #
3881             sub Egbk::f_() {
3882              
3883 0 0   0 0 0 if (-e $_) {
    0          
3884 0 0       0 return -f _ ? 1 : '';
3885             }
3886             elsif (_MSWin32_5Cended_path($_)) {
3887 0 0       0 if (-d "$_/.") {
3888 0         0 return '';
3889             }
3890             else {
3891 0         0 my $fh = gensym();
3892 0 0       0 if (_open_r($fh, $_)) {
3893 0         0 my $f = -f $fh;
3894 0 0       0 close($fh) or die "Can't close file: $_: $!";
3895 0 0       0 return $f ? 1 : '';
3896             }
3897             }
3898             }
3899 0         0 return undef;
3900             }
3901              
3902             #
3903             # GBK file test -d $_
3904             #
3905             sub Egbk::d_() {
3906              
3907 0 0   0 0 0 if (-e $_) {
    0          
3908 0 0       0 return -d _ ? 1 : '';
3909             }
3910             elsif (_MSWin32_5Cended_path($_)) {
3911 0 0       0 return -d "$_/." ? 1 : '';
3912             }
3913 0         0 return undef;
3914             }
3915              
3916             #
3917             # GBK file test -l $_
3918             #
3919             sub Egbk::l_() {
3920              
3921 0 0   0 0 0 if (-e $_) {
    0          
3922 0 0       0 return -l _ ? 1 : '';
3923             }
3924             elsif (_MSWin32_5Cended_path($_)) {
3925 0 0       0 if (-d "$_/.") {
3926 0 0       0 return -l _ ? 1 : '';
3927             }
3928             else {
3929 0         0 my $fh = gensym();
3930 0 0       0 if (_open_r($fh, $_)) {
3931 0         0 my $l = -l $fh;
3932 0 0       0 close($fh) or die "Can't close file: $_: $!";
3933 0 0       0 return $l ? 1 : '';
3934             }
3935             }
3936             }
3937 0         0 return undef;
3938             }
3939              
3940             #
3941             # GBK file test -p $_
3942             #
3943             sub Egbk::p_() {
3944              
3945 0 0   0 0 0 if (-e $_) {
    0          
3946 0 0       0 return -p _ ? 1 : '';
3947             }
3948             elsif (_MSWin32_5Cended_path($_)) {
3949 0 0       0 if (-d "$_/.") {
3950 0 0       0 return -p _ ? 1 : '';
3951             }
3952             else {
3953 0         0 my $fh = gensym();
3954 0 0       0 if (_open_r($fh, $_)) {
3955 0         0 my $p = -p $fh;
3956 0 0       0 close($fh) or die "Can't close file: $_: $!";
3957 0 0       0 return $p ? 1 : '';
3958             }
3959             }
3960             }
3961 0         0 return undef;
3962             }
3963              
3964             #
3965             # GBK file test -S $_
3966             #
3967             sub Egbk::S_() {
3968              
3969 0 0   0 0 0 if (-e $_) {
    0          
3970 0 0       0 return -S _ ? 1 : '';
3971             }
3972             elsif (_MSWin32_5Cended_path($_)) {
3973 0 0       0 if (-d "$_/.") {
3974 0 0       0 return -S _ ? 1 : '';
3975             }
3976             else {
3977 0         0 my $fh = gensym();
3978 0 0       0 if (_open_r($fh, $_)) {
3979 0         0 my $S = -S $fh;
3980 0 0       0 close($fh) or die "Can't close file: $_: $!";
3981 0 0       0 return $S ? 1 : '';
3982             }
3983             }
3984             }
3985 0         0 return undef;
3986             }
3987              
3988             #
3989             # GBK file test -b $_
3990             #
3991             sub Egbk::b_() {
3992              
3993 0 0   0 0 0 if (-e $_) {
    0          
3994 0 0       0 return -b _ ? 1 : '';
3995             }
3996             elsif (_MSWin32_5Cended_path($_)) {
3997 0 0       0 if (-d "$_/.") {
3998 0 0       0 return -b _ ? 1 : '';
3999             }
4000             else {
4001 0         0 my $fh = gensym();
4002 0 0       0 if (_open_r($fh, $_)) {
4003 0         0 my $b = -b $fh;
4004 0 0       0 close($fh) or die "Can't close file: $_: $!";
4005 0 0       0 return $b ? 1 : '';
4006             }
4007             }
4008             }
4009 0         0 return undef;
4010             }
4011              
4012             #
4013             # GBK file test -c $_
4014             #
4015             sub Egbk::c_() {
4016              
4017 0 0   0 0 0 if (-e $_) {
    0          
4018 0 0       0 return -c _ ? 1 : '';
4019             }
4020             elsif (_MSWin32_5Cended_path($_)) {
4021 0 0       0 if (-d "$_/.") {
4022 0 0       0 return -c _ ? 1 : '';
4023             }
4024             else {
4025 0         0 my $fh = gensym();
4026 0 0       0 if (_open_r($fh, $_)) {
4027 0         0 my $c = -c $fh;
4028 0 0       0 close($fh) or die "Can't close file: $_: $!";
4029 0 0       0 return $c ? 1 : '';
4030             }
4031             }
4032             }
4033 0         0 return undef;
4034             }
4035              
4036             #
4037             # GBK file test -u $_
4038             #
4039             sub Egbk::u_() {
4040              
4041 0 0   0 0 0 if (-e $_) {
    0          
4042 0 0       0 return -u _ ? 1 : '';
4043             }
4044             elsif (_MSWin32_5Cended_path($_)) {
4045 0 0       0 if (-d "$_/.") {
4046 0 0       0 return -u _ ? 1 : '';
4047             }
4048             else {
4049 0         0 my $fh = gensym();
4050 0 0       0 if (_open_r($fh, $_)) {
4051 0         0 my $u = -u $fh;
4052 0 0       0 close($fh) or die "Can't close file: $_: $!";
4053 0 0       0 return $u ? 1 : '';
4054             }
4055             }
4056             }
4057 0         0 return undef;
4058             }
4059              
4060             #
4061             # GBK file test -g $_
4062             #
4063             sub Egbk::g_() {
4064              
4065 0 0   0 0 0 if (-e $_) {
    0          
4066 0 0       0 return -g _ ? 1 : '';
4067             }
4068             elsif (_MSWin32_5Cended_path($_)) {
4069 0 0       0 if (-d "$_/.") {
4070 0 0       0 return -g _ ? 1 : '';
4071             }
4072             else {
4073 0         0 my $fh = gensym();
4074 0 0       0 if (_open_r($fh, $_)) {
4075 0         0 my $g = -g $fh;
4076 0 0       0 close($fh) or die "Can't close file: $_: $!";
4077 0 0       0 return $g ? 1 : '';
4078             }
4079             }
4080             }
4081 0         0 return undef;
4082             }
4083              
4084             #
4085             # GBK file test -k $_
4086             #
4087             sub Egbk::k_() {
4088              
4089 0 0   0 0 0 if ($] =~ /^5\.008/oxms) {
4090 0 0       0 return wantarray ? ('',@_) : '';
4091             }
4092 0 0       0 return wantarray ? ($_,@_) : $_;
4093             }
4094              
4095             #
4096             # GBK file test -T $_
4097             #
4098             sub Egbk::T_() {
4099              
4100 0     0 0 0 my $T = 1;
4101              
4102 0 0 0     0 if (-d $_ or -d "$_/.") {
4103 0         0 return undef;
4104             }
4105 0         0 my $fh = gensym();
4106 0 0       0 if (_open_r($fh, $_)) {
4107             }
4108             else {
4109 0         0 return undef;
4110             }
4111              
4112 0 0       0 if (sysread $fh, my $block, 512) {
4113 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4114 0         0 $T = '';
4115             }
4116             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4117 0         0 $T = '';
4118             }
4119             }
4120              
4121             # 0 byte or eof
4122             else {
4123 0         0 $T = 1;
4124             }
4125 0         0 my $dummy_for_underline_cache = -T $fh;
4126 0 0       0 close($fh) or die "Can't close file: $_: $!";
4127              
4128 0         0 return $T;
4129             }
4130              
4131             #
4132             # GBK file test -B $_
4133             #
4134             sub Egbk::B_() {
4135              
4136 0     0 0 0 my $B = '';
4137              
4138 0 0 0     0 if (-d $_ or -d "$_/.") {
4139 0         0 return undef;
4140             }
4141 0         0 my $fh = gensym();
4142 0 0       0 if (_open_r($fh, $_)) {
4143             }
4144             else {
4145 0         0 return undef;
4146             }
4147              
4148 0 0       0 if (sysread $fh, my $block, 512) {
4149 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4150 0         0 $B = 1;
4151             }
4152             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4153 0         0 $B = 1;
4154             }
4155             }
4156              
4157             # 0 byte or eof
4158             else {
4159 0         0 $B = 1;
4160             }
4161 0         0 my $dummy_for_underline_cache = -B $fh;
4162 0 0       0 close($fh) or die "Can't close file: $_: $!";
4163              
4164 0         0 return $B;
4165             }
4166              
4167             #
4168             # GBK file test -M $_
4169             #
4170             sub Egbk::M_() {
4171              
4172 0 0   0 0 0 if (-e $_) {
    0          
4173 0         0 return -M _;
4174             }
4175             elsif (_MSWin32_5Cended_path($_)) {
4176 0 0       0 if (-d "$_/.") {
4177 0         0 return -M _;
4178             }
4179             else {
4180 0         0 my $fh = gensym();
4181 0 0       0 if (_open_r($fh, $_)) {
4182 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4183 0 0       0 close($fh) or die "Can't close file: $_: $!";
4184 0         0 my $M = ($^T - $mtime) / (24*60*60);
4185 0         0 return $M;
4186             }
4187             }
4188             }
4189 0         0 return undef;
4190             }
4191              
4192             #
4193             # GBK file test -A $_
4194             #
4195             sub Egbk::A_() {
4196              
4197 0 0   0 0 0 if (-e $_) {
    0          
4198 0         0 return -A _;
4199             }
4200             elsif (_MSWin32_5Cended_path($_)) {
4201 0 0       0 if (-d "$_/.") {
4202 0         0 return -A _;
4203             }
4204             else {
4205 0         0 my $fh = gensym();
4206 0 0       0 if (_open_r($fh, $_)) {
4207 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4208 0 0       0 close($fh) or die "Can't close file: $_: $!";
4209 0         0 my $A = ($^T - $atime) / (24*60*60);
4210 0         0 return $A;
4211             }
4212             }
4213             }
4214 0         0 return undef;
4215             }
4216              
4217             #
4218             # GBK file test -C $_
4219             #
4220             sub Egbk::C_() {
4221              
4222 0 0   0 0 0 if (-e $_) {
    0          
4223 0         0 return -C _;
4224             }
4225             elsif (_MSWin32_5Cended_path($_)) {
4226 0 0       0 if (-d "$_/.") {
4227 0         0 return -C _;
4228             }
4229             else {
4230 0         0 my $fh = gensym();
4231 0 0       0 if (_open_r($fh, $_)) {
4232 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4233 0 0       0 close($fh) or die "Can't close file: $_: $!";
4234 0         0 my $C = ($^T - $ctime) / (24*60*60);
4235 0         0 return $C;
4236             }
4237             }
4238             }
4239 0         0 return undef;
4240             }
4241              
4242             #
4243             # GBK path globbing (with parameter)
4244             #
4245             sub Egbk::glob($) {
4246              
4247 0 0   0 0 0 if (wantarray) {
4248 0         0 my @glob = _DOS_like_glob(@_);
4249 0         0 for my $glob (@glob) {
4250 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4251             }
4252 0         0 return @glob;
4253             }
4254             else {
4255 0         0 my $glob = _DOS_like_glob(@_);
4256 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4257 0         0 return $glob;
4258             }
4259             }
4260              
4261             #
4262             # GBK path globbing (without parameter)
4263             #
4264             sub Egbk::glob_() {
4265              
4266 0 0   0 0 0 if (wantarray) {
4267 0         0 my @glob = _DOS_like_glob();
4268 0         0 for my $glob (@glob) {
4269 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4270             }
4271 0         0 return @glob;
4272             }
4273             else {
4274 0         0 my $glob = _DOS_like_glob();
4275 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4276 0         0 return $glob;
4277             }
4278             }
4279              
4280             #
4281             # GBK path globbing via File::DosGlob 1.10
4282             #
4283             # Often I confuse "_dosglob" and "_doglob".
4284             # So, I renamed "_dosglob" to "_DOS_like_glob".
4285             #
4286             my %iter;
4287             my %entries;
4288             sub _DOS_like_glob {
4289              
4290             # context (keyed by second cxix argument provided by core)
4291 0     0   0 my($expr,$cxix) = @_;
4292              
4293             # glob without args defaults to $_
4294 0 0       0 $expr = $_ if not defined $expr;
4295              
4296             # represents the current user's home directory
4297             #
4298             # 7.3. Expanding Tildes in Filenames
4299             # in Chapter 7. File Access
4300             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4301             #
4302             # and File::HomeDir, File::HomeDir::Windows module
4303              
4304             # DOS-like system
4305 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4306 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
4307             { my_home_MSWin32() }oxmse;
4308             }
4309              
4310             # UNIX-like system
4311 0 0 0     0 else {
  0         0  
4312             $expr =~ s{ \A ~ ( (?:[^\x81-\xFE/]|[\x81-\xFE][\x00-\xFF])* ) }
4313             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
4314             }
4315 0 0       0  
4316 0 0       0 # assume global context if not provided one
4317             $cxix = '_G_' if not defined $cxix;
4318             $iter{$cxix} = 0 if not exists $iter{$cxix};
4319 0 0       0  
4320 0         0 # if we're just beginning, do it all first
4321             if ($iter{$cxix} == 0) {
4322             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
4323             }
4324 0 0       0  
4325 0         0 # chuck it all out, quick or slow
4326 0         0 if (wantarray) {
  0         0  
4327             delete $iter{$cxix};
4328             return @{delete $entries{$cxix}};
4329 0 0       0 }
  0         0  
4330 0         0 else {
  0         0  
4331             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
4332             return shift @{$entries{$cxix}};
4333             }
4334 0         0 else {
4335 0         0 # return undef for EOL
4336 0         0 delete $iter{$cxix};
4337             delete $entries{$cxix};
4338             return undef;
4339             }
4340             }
4341             }
4342              
4343             #
4344             # GBK path globbing subroutine
4345             #
4346 0     0   0 sub _do_glob {
4347 0         0  
4348 0         0 my($cond,@expr) = @_;
4349             my @glob = ();
4350             my $fix_drive_relative_paths = 0;
4351 0         0  
4352 0 0       0 OUTER:
4353 0 0       0 for my $expr (@expr) {
4354             next OUTER if not defined $expr;
4355 0         0 next OUTER if $expr eq '';
4356 0         0  
4357 0         0 my @matched = ();
4358 0         0 my @globdir = ();
4359 0         0 my $head = '.';
4360             my $pathsep = '/';
4361             my $tail;
4362 0 0       0  
4363 0         0 # if argument is within quotes strip em and do no globbing
4364 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
4365 0 0       0 $expr = $1;
4366 0         0 if ($cond eq 'd') {
4367             if (Egbk::d $expr) {
4368             push @glob, $expr;
4369             }
4370 0 0       0 }
4371 0         0 else {
4372             if (Egbk::e $expr) {
4373             push @glob, $expr;
4374 0         0 }
4375             }
4376             next OUTER;
4377             }
4378              
4379 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
4380 0 0       0 # to h:./*.pm to expand correctly
4381 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4382             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^\x81-\xFE/\\]|[\x81-\xFE][\x00-\xFF]) #$1./$2#oxms) {
4383             $fix_drive_relative_paths = 1;
4384             }
4385 0 0       0 }
4386 0 0       0  
4387 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
4388 0         0 if ($tail eq '') {
4389             push @glob, $expr;
4390 0 0       0 next OUTER;
4391 0 0       0 }
4392 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
4393 0         0 if (@globdir = _do_glob('d', $head)) {
4394             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
4395             next OUTER;
4396 0 0 0     0 }
4397 0         0 }
4398             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
4399 0         0 $head .= $pathsep;
4400             }
4401             $expr = $tail;
4402             }
4403 0 0       0  
4404 0 0       0 # If file component has no wildcards, we can avoid opendir
4405 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
4406             if ($head eq '.') {
4407 0 0 0     0 $head = '';
4408 0         0 }
4409             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4410 0         0 $head .= $pathsep;
4411 0 0       0 }
4412 0 0       0 $head .= $expr;
4413 0         0 if ($cond eq 'd') {
4414             if (Egbk::d $head) {
4415             push @glob, $head;
4416             }
4417 0 0       0 }
4418 0         0 else {
4419             if (Egbk::e $head) {
4420             push @glob, $head;
4421 0         0 }
4422             }
4423 0 0       0 next OUTER;
4424 0         0 }
4425 0         0 Egbk::opendir(*DIR, $head) or next OUTER;
4426             my @leaf = readdir DIR;
4427 0 0       0 closedir DIR;
4428 0         0  
4429             if ($head eq '.') {
4430 0 0 0     0 $head = '';
4431 0         0 }
4432             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4433             $head .= $pathsep;
4434 0         0 }
4435 0         0  
4436 0         0 my $pattern = '';
4437             while ($expr =~ / \G ($q_char) /oxgc) {
4438             my $char = $1;
4439              
4440             # 6.9. Matching Shell Globs as Regular Expressions
4441             # in Chapter 6. Pattern Matching
4442             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4443 0 0       0 # (and so on)
    0          
    0          
4444 0         0  
4445             if ($char eq '*') {
4446             $pattern .= "(?:$your_char)*",
4447 0         0 }
4448             elsif ($char eq '?') {
4449             $pattern .= "(?:$your_char)?", # DOS style
4450             # $pattern .= "(?:$your_char)", # UNIX style
4451 0         0 }
4452             elsif ((my $fc = Egbk::fc($char)) ne $char) {
4453             $pattern .= $fc;
4454 0         0 }
4455             else {
4456             $pattern .= quotemeta $char;
4457 0     0   0 }
  0         0  
4458             }
4459             my $matchsub = sub { Egbk::fc($_[0]) =~ /\A $pattern \z/xms };
4460              
4461             # if ($@) {
4462             # print STDERR "$0: $@\n";
4463             # next OUTER;
4464             # }
4465 0         0  
4466 0 0 0     0 INNER:
4467 0         0 for my $leaf (@leaf) {
4468             if ($leaf eq '.' or $leaf eq '..') {
4469 0 0 0     0 next INNER;
4470 0         0 }
4471             if ($cond eq 'd' and not Egbk::d "$head$leaf") {
4472             next INNER;
4473 0 0       0 }
4474 0         0  
4475 0         0 if (&$matchsub($leaf)) {
4476             push @matched, "$head$leaf";
4477             next INNER;
4478             }
4479              
4480             # [DOS compatibility special case]
4481 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
4482              
4483             if (Egbk::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
4484             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
4485 0 0       0 Egbk::index($pattern,'\\.') != -1 # pattern has a dot.
4486 0         0 ) {
4487 0         0 if (&$matchsub("$leaf.")) {
4488             push @matched, "$head$leaf";
4489             next INNER;
4490             }
4491 0 0       0 }
4492 0         0 }
4493             if (@matched) {
4494             push @glob, @matched;
4495 0 0       0 }
4496 0         0 }
4497 0         0 if ($fix_drive_relative_paths) {
4498             for my $glob (@glob) {
4499             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
4500 0         0 }
4501             }
4502             return @glob;
4503             }
4504              
4505             #
4506             # GBK parse line
4507             #
4508 0     0   0 sub _parse_line {
4509              
4510 0         0 my($line) = @_;
4511 0         0  
4512 0         0 $line .= ' ';
4513             my @piece = ();
4514             while ($line =~ /
4515             " ( (?>(?: [^\x81-\xFE"] |[\x81-\xFE][\x00-\xFF] )* ) ) " (?>\s+) |
4516             ( (?>(?: [^\x81-\xFE"\s]|[\x81-\xFE][\x00-\xFF] )* ) ) (?>\s+)
4517 0 0       0 /oxmsg
4518             ) {
4519 0         0 push @piece, defined($1) ? $1 : $2;
4520             }
4521             return @piece;
4522             }
4523              
4524             #
4525             # GBK parse path
4526             #
4527 0     0   0 sub _parse_path {
4528              
4529 0         0 my($path,$pathsep) = @_;
4530 0         0  
4531 0         0 $path .= '/';
4532             my @subpath = ();
4533             while ($path =~ /
4534             ((?: [^\x81-\xFE\/\\]|[\x81-\xFE][\x00-\xFF] )+?) [\/\\]
4535 0         0 /oxmsg
4536             ) {
4537             push @subpath, $1;
4538 0         0 }
4539 0         0  
4540 0         0 my $tail = pop @subpath;
4541             my $head = join $pathsep, @subpath;
4542             return $head, $tail;
4543             }
4544              
4545             #
4546             # via File::HomeDir::Windows 1.00
4547             #
4548             sub my_home_MSWin32 {
4549              
4550             # A lot of unix people and unix-derived tools rely on
4551 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
4552 0         0 # so that they can replace raw HOME calls with File::HomeDir.
4553             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
4554             return $ENV{'HOME'};
4555             }
4556              
4557 0         0 # Do we have a user profile?
4558             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
4559             return $ENV{'USERPROFILE'};
4560             }
4561              
4562 0         0 # Some Windows use something like $ENV{'HOME'}
4563             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
4564             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
4565 0         0 }
4566              
4567             return undef;
4568             }
4569              
4570             #
4571             # via File::HomeDir::Unix 1.00
4572 0     0 0 0 #
4573             sub my_home {
4574 0 0 0     0 my $home;
    0 0        
4575 0         0  
4576             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
4577             $home = $ENV{'HOME'};
4578             }
4579              
4580             # This is from the original code, but I'm guessing
4581 0         0 # it means "login directory" and exists on some Unixes.
4582             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
4583             $home = $ENV{'LOGDIR'};
4584             }
4585              
4586             ### More-desperate methods
4587              
4588 0         0 # Light desperation on any (Unixish) platform
4589             else {
4590             $home = CORE::eval q{ (getpwuid($<))[7] };
4591             }
4592              
4593 0 0 0     0 # On Unix in general, a non-existant home means "no home"
4594 0         0 # For example, "nobody"-like users might use /nonexistant
4595             if (defined $home and ! Egbk::d($home)) {
4596 0         0 $home = undef;
4597             }
4598             return $home;
4599             }
4600              
4601             #
4602             # GBK file lstat (with parameter)
4603             #
4604 0 0   0 0 0 sub Egbk::lstat(*) {
4605              
4606 0 0       0 local $_ = shift if @_;
    0          
4607 0         0  
4608             if (-e $_) {
4609             return CORE::lstat _;
4610             }
4611             elsif (_MSWin32_5Cended_path($_)) {
4612              
4613             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Egbk::lstat()
4614             # on Windows opens the file for the path which has 5c at end.
4615 0         0 # (and so on)
4616 0 0       0  
4617 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4618 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4619 0 0       0 if (wantarray) {
4620 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4621             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4622             return @stat;
4623 0         0 }
4624 0 0       0 else {
4625 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4626             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4627             return $stat;
4628             }
4629 0 0       0 }
4630             }
4631             return wantarray ? () : undef;
4632             }
4633              
4634             #
4635             # GBK file lstat (without parameter)
4636             #
4637 0 0   0 0 0 sub Egbk::lstat_() {
    0          
4638 0         0  
4639             if (-e $_) {
4640             return CORE::lstat _;
4641 0         0 }
4642 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4643 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4644 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4645 0 0       0 if (wantarray) {
4646 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4647             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4648             return @stat;
4649 0         0 }
4650 0 0       0 else {
4651 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4652             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4653             return $stat;
4654             }
4655 0 0       0 }
4656             }
4657             return wantarray ? () : undef;
4658             }
4659              
4660             #
4661             # GBK path opendir
4662             #
4663 0     0 0 0 sub Egbk::opendir(*$) {
4664 0 0       0  
    0          
4665 0         0 my $dh = qualify_to_ref $_[0];
4666             if (CORE::opendir $dh, $_[1]) {
4667             return 1;
4668 0 0       0 }
4669 0         0 elsif (_MSWin32_5Cended_path($_[1])) {
4670             if (CORE::opendir $dh, "$_[1]/.") {
4671             return 1;
4672 0         0 }
4673             }
4674             return undef;
4675             }
4676              
4677             #
4678             # GBK file stat (with parameter)
4679             #
4680 0 50   384 0 0 sub Egbk::stat(*) {
4681              
4682 384         2425 local $_ = shift if @_;
4683 384 50       2404  
    50          
    0          
4684 384         13378 my $fh = qualify_to_ref $_;
4685             if (defined fileno $fh) {
4686             return CORE::stat $fh;
4687 0         0 }
4688             elsif (-e $_) {
4689             return CORE::stat _;
4690             }
4691             elsif (_MSWin32_5Cended_path($_)) {
4692              
4693             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Egbk::stat()
4694             # on Windows opens the file for the path which has 5c at end.
4695 384         3100 # (and so on)
4696 0 0       0  
4697 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4698 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4699 0 0       0 if (wantarray) {
4700 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4701             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4702             return @stat;
4703 0         0 }
4704 0 0       0 else {
4705 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4706             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4707             return $stat;
4708             }
4709 0 0       0 }
4710             }
4711             return wantarray ? () : undef;
4712             }
4713              
4714             #
4715             # GBK file stat (without parameter)
4716             #
4717 0     0 0 0 sub Egbk::stat_() {
4718 0 0       0  
    0          
    0          
4719 0         0 my $fh = qualify_to_ref $_;
4720             if (defined fileno $fh) {
4721             return CORE::stat $fh;
4722 0         0 }
4723             elsif (-e $_) {
4724             return CORE::stat _;
4725 0         0 }
4726 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4727 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4728 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4729 0 0       0 if (wantarray) {
4730 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4731             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4732             return @stat;
4733 0         0 }
4734 0 0       0 else {
4735 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4736             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4737             return $stat;
4738             }
4739 0 0       0 }
4740             }
4741             return wantarray ? () : undef;
4742             }
4743              
4744             #
4745             # GBK path unlink
4746             #
4747 0 0   0 0 0 sub Egbk::unlink(@) {
4748              
4749 0         0 local @_ = ($_) unless @_;
4750 0         0  
4751 0 0       0 my $unlink = 0;
    0          
    0          
4752 0         0 for (@_) {
4753             if (CORE::unlink) {
4754             $unlink++;
4755             }
4756             elsif (Egbk::d($_)) {
4757 0         0 }
4758 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
  0         0  
4759 0 0       0 my @char = /\G (?>$q_char) /oxmsg;
4760 0         0 my $file = join '', map {{'/' => '\\'}->{$_} || $_} @char;
4761             if ($file =~ / \A (?:$q_char)*? [ ] /oxms) {
4762 0         0 $file = qq{"$file"};
4763 0 0       0 }
4764 0 0       0 my $fh = gensym();
4765             if (_open_r($fh, $_)) {
4766             close($fh) or die "Can't close file: $_: $!";
4767 0 0 0     0  
    0          
4768 0         0 # cmd.exe on Windows NT, Windows 2000, Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
4769             if ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
4770             CORE::system 'DEL', '/F', $file, '2>NUL';
4771             }
4772              
4773 0         0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
4774             elsif (qx{ver} =~ /\b(?:Windows 2000)\b/oms) {
4775             CORE::system 'DEL', '/F', $file, '2>NUL';
4776             }
4777              
4778             # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
4779 0         0 # command.com can not "2>NUL"
4780 0         0 else {
4781             CORE::system 'ATTRIB', '-R', $file; # clears Read-only file attribute
4782             CORE::system 'DEL', $file;
4783 0 0       0 }
4784 0 0       0  
4785             if (_open_r($fh, $_)) {
4786             close($fh) or die "Can't close file: $_: $!";
4787 0         0 }
4788             else {
4789             $unlink++;
4790             }
4791             }
4792 0         0 }
4793             }
4794             return $unlink;
4795             }
4796              
4797             #
4798             # GBK chdir
4799             #
4800 0 0   0 0 0 sub Egbk::chdir(;$) {
4801 0         0  
4802             if (@_ == 0) {
4803             return CORE::chdir;
4804 0         0 }
4805              
4806 0 0       0 my($dir) = @_;
4807 0 0       0  
4808 0         0 if (_MSWin32_5Cended_path($dir)) {
4809             if (not Egbk::d $dir) {
4810             return 0;
4811 0 0 0     0 }
    0          
4812 0         0  
4813             if ($] =~ /^5\.005/oxms) {
4814             return CORE::chdir $dir;
4815 0         0 }
4816 0         0 elsif (($] =~ /^(?:5\.006|5\.008000)/oxms) and ($^O eq 'MSWin32')) {
4817             local $@;
4818             my $chdir = CORE::eval q{
4819             CORE::require 'jacode.pl';
4820              
4821             # P.676 ${^WIDE_SYSTEM_CALLS}
4822             # in Chapter 28: Special Names
4823             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4824              
4825             # P.790 ${^WIDE_SYSTEM_CALLS}
4826             # in Chapter 25: Special Names
4827             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4828              
4829             local ${^WIDE_SYSTEM_CALLS} = 1;
4830 0 0       0 return CORE::chdir jcode::utf8($dir,'sjis');
4831 0         0 };
4832             if (not $@) {
4833             return $chdir;
4834             }
4835             }
4836              
4837             # old idea (Win32 module required)
4838             elsif (0) {
4839             local $@;
4840             my $shortdir = '';
4841             my $chdir = CORE::eval q{
4842             use Win32;
4843             $shortdir = Win32::GetShortPathName($dir);
4844             if ($shortdir ne $dir) {
4845             return CORE::chdir $shortdir;
4846             }
4847             else {
4848             return 0;
4849             }
4850             };
4851             if ($@) {
4852             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4853             while ($char[-1] eq "\x5C") {
4854             pop @char;
4855             }
4856             $dir = join '', @char;
4857             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path), Win32.pm module may help you";
4858             }
4859             elsif ($shortdir eq $dir) {
4860             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4861             while ($char[-1] eq "\x5C") {
4862             pop @char;
4863             }
4864             $dir = join '', @char;
4865             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path)";
4866             }
4867             return $chdir;
4868             }
4869 0         0  
4870             # rejected idea ...
4871             elsif (0) {
4872              
4873             # MSDN SetCurrentDirectory function
4874             # http://msdn.microsoft.com/ja-jp/library/windows/desktop/aa365530(v=vs.85).aspx
4875             #
4876             # Data Execution Prevention (DEP)
4877             # http://vlaurie.com/computers2/Articles/dep.htm
4878             #
4879             # Learning x86 assembler with Perl -- Shibuya.pm#11
4880             # http://developer.cybozu.co.jp/takesako/2009/06/perl-x86-shibuy.html
4881             #
4882             # Introduction to Win32::API programming in Perl
4883             # http://d.hatena.ne.jp/TAKESAKO/20090324/1237879559
4884             #
4885             # DynaLoader - Dynamically load C libraries into Perl code
4886             # http://perldoc.perl.org/DynaLoader.html
4887             #
4888             # Basic knowledge of DynaLoader
4889             # http://blog.64p.org/entry/20090313/1236934042
4890              
4891             if (($] =~ /^5\.006/oxms) and
4892             ($^O eq 'MSWin32') and
4893             ($ENV{'PROCESSOR_ARCHITECTURE'} eq 'x86') and
4894             CORE::eval(q{CORE::require 'Dyna'.'Loader'})
4895             ) {
4896             my $x86 = join('',
4897              
4898             # PUSH Iv
4899             "\x68", pack('P', "$dir\\\0"),
4900              
4901             # MOV eAX, Iv
4902             "\xb8", pack('L',
4903             *{'Dyna'.'Loader::dl_find_symbol'}{'CODE'}->(
4904             *{'Dyna'.'Loader::dl_load_file'}{'CODE'}->("$ENV{'SystemRoot'}\\system32\\kernel32.dll"),
4905             'SetCurrentDirectoryA'
4906             )
4907             ),
4908              
4909             # CALL eAX
4910             "\xff\xd0",
4911              
4912             # RETN
4913             "\xc3",
4914             );
4915             *{'Dyna'.'Loader::dl_install_xsub'}{'CODE'}->('_SetCurrentDirectoryA', unpack('L', pack 'P', $x86));
4916             _SetCurrentDirectoryA();
4917             chomp(my $chdir = qx{chdir});
4918             if (Egbk::fc($chdir) eq Egbk::fc($dir)) {
4919             return 1;
4920             }
4921             else {
4922             return 0;
4923             }
4924             }
4925             }
4926              
4927             # COMMAND.COM's unhelpful tips:
4928             # Displays a list of files and subdirectories in a directory.
4929             # http://www.lagmonster.org/docs/DOS7/z-dir.html
4930             #
4931             # Syntax:
4932             #
4933             # DIR [drive:] [path] [filename] [/Switches]
4934             #
4935             # /Z Long file names are not displayed in the file listing
4936             #
4937             # Limitations
4938             # The undocumented /Z switch (no long names) would appear to
4939             # have been not fully developed and has a couple of problems:
4940             #
4941             # 1. It will only work if:
4942             # There is no path specified (ie. for the current directory in
4943             # the current drive)
4944             # The path is specified as the root directory of any drive
4945             # (eg. C:\, D:\, etc.)
4946             # The path is specified as the current directory of any drive
4947             # by using the drive letter only (eg. C:, D:, etc.)
4948             # The path is specified as the parent directory using the ..
4949             # notation (eg. DIR .. /Z)
4950             # Any other syntax results in a "File Not Found" error message.
4951             #
4952             # 2. The /Z switch is compatable with the /S switch to show
4953             # subdirectories (as long as the above rules are followed) and
4954             # all the files are shown with short names only. The
4955             # subdirectories are also shown with short names only. However,
4956             # the header for each subdirectory after the first level gives
4957             # the subdirectory's long name.
4958             #
4959             # 3. The /Z switch is also compatable with the /B switch to give
4960             # a simple list of files with short names only. When used with
4961             # the /S switch as well, all files are listed with their full
4962             # paths. The file names themselves are all in short form, and
4963             # the path of those files in the current directory are in short
4964             # form, but the paths of any files in subdirectories are in
4965 0         0 # long filename form.
4966 0         0  
4967 0         0 my $shortdir = '';
4968 0         0 my $i = 0;
4969 0         0 my @subdir = ();
4970 0 0 0     0 while ($dir =~ / \G ($q_char) /oxgc) {
4971 0         0 my $char = $1;
4972 0         0 if (($char eq '\\') or ($char eq '/')) {
4973 0         0 $i++;
4974             $subdir[$i] = $char;
4975             $i++;
4976 0         0 }
4977             else {
4978             $subdir[$i] .= $char;
4979 0 0 0     0 }
4980 0         0 }
4981             if (($subdir[-1] eq '\\') or ($subdir[-1] eq '/')) {
4982             pop @subdir;
4983             }
4984              
4985             # P.504 PERL5SHELL (Microsoft ports only)
4986             # in Chapter 19: The Command-Line Interface
4987             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4988              
4989             # P.597 PERL5SHELL (Microsoft ports only)
4990             # in Chapter 17: The Command-Line Interface
4991             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4992              
4993 0 0 0     0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
    0          
4994 0         0 # cmd.exe on Windows NT, Windows 2000
4995 0         0 if (qx{ver} =~ /\b(?:Windows NT|Windows 2000)\b/oms) {
  0         0  
4996 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
4997             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
4998             if (Egbk::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Egbk::fc($subdir[-1])) {
4999 0         0  
5000 0         0 # short file name (8dot3name) here-----vv
5001 0         0 my $shortleafdir = CORE::substr $dirx, 39, 8+1+3;
5002 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5003             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5004             last;
5005             }
5006             }
5007             }
5008              
5009             # an idea (not so portable, only Windows 2000 or later)
5010             elsif (0) {
5011             chomp($shortdir = qx{for %I in ("$dir") do \@echo %~sI 2>NUL});
5012             }
5013              
5014 0         0 # cmd.exe on Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
5015 0         0 elsif ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
  0         0  
5016 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5017             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5018             if (Egbk::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Egbk::fc($subdir[-1])) {
5019 0         0  
5020 0         0 # short file name (8dot3name) here-----vv
5021 0         0 my $shortleafdir = CORE::substr $dirx, 36, 8+1+3;
5022 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5023             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5024             last;
5025             }
5026             }
5027             }
5028              
5029 0         0 # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
5030 0         0 else {
  0         0  
5031 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad "$dir*"});
5032             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5033             if (Egbk::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Egbk::fc($subdir[-1])) {
5034 0         0  
5035 0         0 # short file name (8dot3name) here-----v
5036 0         0 my $shortleafdir = CORE::substr $dirx, 0, 8+1+3;
5037 0         0 CORE::substr($shortleafdir,8,1) = '.';
5038 0         0 $shortleafdir =~ s/ \. [ ]+ \z//oxms;
5039             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5040             last;
5041             }
5042             }
5043 0 0       0 }
    0          
5044 0         0  
5045             if ($shortdir eq '') {
5046             return 0;
5047 0         0 }
5048             elsif (Egbk::fc($shortdir) eq Egbk::fc($dir)) {
5049 0         0 return 0;
5050             }
5051             return CORE::chdir $shortdir;
5052 0         0 }
5053             else {
5054             return CORE::chdir $dir;
5055             }
5056             }
5057              
5058             #
5059             # GBK chr(0x5C) ended path on MSWin32
5060             #
5061 0 50 33 768   0 sub _MSWin32_5Cended_path {
5062 768 50       4848  
5063 768         4392 if ((@_ >= 1) and ($_[0] ne '')) {
5064 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
5065 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5066             if ($char[-1] =~ / \x5C \z/oxms) {
5067             return 1;
5068             }
5069 0         0 }
5070             }
5071             return undef;
5072             }
5073              
5074             #
5075             # do GBK file
5076             #
5077 768     0 0 1895 sub Egbk::do($) {
5078              
5079 0         0 my($filename) = @_;
5080              
5081             my $realfilename;
5082             my $result;
5083 0         0 ITER_DO:
  0         0  
5084 0 0       0 {
5085 0         0 for my $prefix (@INC) {
5086             if ($^O eq 'MacOS') {
5087             $realfilename = "$prefix$filename";
5088 0         0 }
5089             else {
5090             $realfilename = "$prefix/$filename";
5091 0 0       0 }
5092              
5093 0         0 if (Egbk::f($realfilename)) {
5094              
5095 0 0       0 my $script = '';
5096 0         0  
5097 0         0 if (Egbk::e("$realfilename.e")) {
5098 0         0 my $e_mtime = (Egbk::stat("$realfilename.e"))[9];
5099 0 0 0     0 my $mtime = (Egbk::stat($realfilename))[9];
5100 0         0 my $module_mtime = (Egbk::stat(__FILE__))[9];
5101             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5102             Egbk::unlink "$realfilename.e";
5103             }
5104 0 0       0 }
5105 0         0  
5106 0 0       0 if (Egbk::e("$realfilename.e")) {
5107 0 0       0 my $fh = gensym();
    0          
5108 0         0 if (_open_r($fh, "$realfilename.e")) {
5109             if ($^O eq 'MacOS') {
5110             CORE::eval q{
5111             CORE::require Mac::Files;
5112             Mac::Files::FSpSetFLock("$realfilename.e");
5113             };
5114             }
5115             elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5116              
5117             # P.419 File Locking
5118             # in Chapter 16: Interprocess Communication
5119             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5120              
5121             # P.524 File Locking
5122             # in Chapter 15: Interprocess Communication
5123             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5124              
5125 0         0 # (and so on)
5126 0 0       0  
5127 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5128             if ($@) {
5129             carp "Can't immediately read-lock the file: $realfilename.e";
5130             }
5131 0         0 }
5132             else {
5133 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5134 0         0 }
5135 0 0       0 local $/ = undef; # slurp mode
5136 0         0 $script = <$fh>;
5137             if ($^O eq 'MacOS') {
5138             CORE::eval q{
5139             CORE::require Mac::Files;
5140             Mac::Files::FSpRstFLock("$realfilename.e");
5141 0 0       0 };
5142             }
5143             close($fh) or die "Can't close file: $realfilename.e: $!";
5144             }
5145 0         0 }
5146 0 0       0 else {
5147 0 0       0 my $fh = gensym();
    0          
5148 0         0 if (_open_r($fh, $realfilename)) {
5149             if ($^O eq 'MacOS') {
5150             CORE::eval q{
5151             CORE::require Mac::Files;
5152             Mac::Files::FSpSetFLock($realfilename);
5153             };
5154 0         0 }
5155 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5156 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5157             if ($@) {
5158             carp "Can't immediately read-lock the file: $realfilename";
5159             }
5160 0         0 }
5161             else {
5162 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5163 0         0 }
5164 0 0       0 local $/ = undef; # slurp mode
5165 0         0 $script = <$fh>;
5166             if ($^O eq 'MacOS') {
5167             CORE::eval q{
5168             CORE::require Mac::Files;
5169             Mac::Files::FSpRstFLock($realfilename);
5170 0 0       0 };
5171             }
5172             close($fh) or die "Can't close file: $realfilename.e: $!";
5173 0 0       0 }
5174 0         0  
5175 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) GBK (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5176 0         0 CORE::require GBK;
5177 0 0       0 $script = GBK::escape_script($script);
5178 0 0       0 my $fh = gensym();
    0          
5179 0         0 open($fh, ">$realfilename.e") or die __FILE__, ": Can't write open file: $realfilename.e\n";
5180             if ($^O eq 'MacOS') {
5181             CORE::eval q{
5182             CORE::require Mac::Files;
5183             Mac::Files::FSpSetFLock("$realfilename.e");
5184             };
5185 0         0 }
5186 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5187 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5188             if ($@) {
5189             carp "Can't immediately write-lock the file: $realfilename.e";
5190             }
5191 0         0 }
5192             else {
5193 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5194 0 0       0 }
5195 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5196 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5197 0         0 print {$fh} $script;
5198             if ($^O eq 'MacOS') {
5199             CORE::eval q{
5200             CORE::require Mac::Files;
5201             Mac::Files::FSpRstFLock("$realfilename.e");
5202 0 0       0 };
5203             }
5204             close($fh) or die "Can't close file: $realfilename.e: $!";
5205             }
5206             }
5207 389     389   12604  
  389         3302  
  389         347699  
  0         0  
5208 0         0 {
5209             no strict;
5210 0         0 $result = scalar CORE::eval $script;
5211             }
5212             last ITER_DO;
5213             }
5214             }
5215 0 0       0 }
    0          
5216 0         0  
5217 0         0 if ($@) {
5218             $INC{$filename} = undef;
5219             return undef;
5220 0         0 }
5221             elsif (not $result) {
5222             return undef;
5223 0         0 }
5224 0         0 else {
5225             $INC{$filename} = $realfilename;
5226             return $result;
5227             }
5228             }
5229              
5230             #
5231             # require GBK file
5232             #
5233              
5234             # require
5235             # in Chapter 3: Functions
5236             # of ISBN 1-56592-149-6 Programming Perl, Second Edition.
5237             #
5238             # sub require {
5239             # my($filename) = @_;
5240             # return 1 if $INC{$filename};
5241             # my($realfilename, $result);
5242             # ITER: {
5243             # foreach $prefix (@INC) {
5244             # $realfilename = "$prefix/$filename";
5245             # if (-f $realfilename) {
5246             # $result = CORE::eval `cat $realfilename`;
5247             # last ITER;
5248             # }
5249             # }
5250             # die "Can't find $filename in \@INC";
5251             # }
5252             # die $@ if $@;
5253             # die "$filename did not return true value" unless $result;
5254             # $INC{$filename} = $realfilename;
5255             # return $result;
5256             # }
5257              
5258             # require
5259             # in Chapter 9: perlfunc: Perl builtin functions
5260             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
5261             #
5262             # sub require {
5263             # my($filename) = @_;
5264             # if (exists $INC{$filename}) {
5265             # return 1 if $INC{$filename};
5266             # die "Compilation failed in require";
5267             # }
5268             # my($realfilename, $result);
5269             # ITER: {
5270             # foreach $prefix (@INC) {
5271             # $realfilename = "$prefix/$filename";
5272             # if (-f $realfilename) {
5273             # $INC{$filename} = $realfilename;
5274             # $result = do $realfilename;
5275             # last ITER;
5276             # }
5277             # }
5278             # die "Can't find $filename in \@INC";
5279             # }
5280             # if ($@) {
5281             # $INC{$filename} = undef;
5282             # die $@;
5283             # }
5284             # elsif (!$result) {
5285             # delete $INC{$filename};
5286             # die "$filename did not return true value";
5287             # }
5288             # else {
5289             # return $result;
5290             # }
5291             # }
5292              
5293 0 0   0 0 0 sub Egbk::require(;$) {
5294              
5295 0 0       0 local $_ = shift if @_;
5296 0 0       0  
5297 0         0 if (exists $INC{$_}) {
5298             return 1 if $INC{$_};
5299             croak "Compilation failed in require: $_";
5300             }
5301              
5302             # jcode.pl
5303             # ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
5304              
5305             # jacode.pl
5306 0 0       0 # http://search.cpan.org/dist/jacode/
5307 0         0  
5308             if (/ \b (?: jcode\.pl | jacode(?>[0-9]*)\.pl ) \z /oxms) {
5309             return CORE::require($_);
5310 0         0 }
5311              
5312             my $realfilename;
5313             my $result;
5314 0         0 ITER_REQUIRE:
  0         0  
5315 0 0       0 {
5316 0         0 for my $prefix (@INC) {
5317             if ($^O eq 'MacOS') {
5318             $realfilename = "$prefix$_";
5319 0         0 }
5320             else {
5321             $realfilename = "$prefix/$_";
5322 0 0       0 }
5323 0         0  
5324             if (Egbk::f($realfilename)) {
5325 0         0 $INC{$_} = $realfilename;
5326              
5327 0 0       0 my $script = '';
5328 0         0  
5329 0         0 if (Egbk::e("$realfilename.e")) {
5330 0         0 my $e_mtime = (Egbk::stat("$realfilename.e"))[9];
5331 0 0 0     0 my $mtime = (Egbk::stat($realfilename))[9];
5332 0         0 my $module_mtime = (Egbk::stat(__FILE__))[9];
5333             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5334             Egbk::unlink "$realfilename.e";
5335             }
5336 0 0       0 }
5337 0         0  
5338 0 0       0 if (Egbk::e("$realfilename.e")) {
5339 0 0       0 my $fh = gensym();
    0          
5340 0         0 _open_r($fh, "$realfilename.e") or croak "Can't open file: $realfilename.e";
5341             if ($^O eq 'MacOS') {
5342             CORE::eval q{
5343             CORE::require Mac::Files;
5344             Mac::Files::FSpSetFLock("$realfilename.e");
5345             };
5346 0         0 }
5347 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5348 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5349             if ($@) {
5350             carp "Can't immediately read-lock the file: $realfilename.e";
5351             }
5352 0         0 }
5353             else {
5354 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5355 0         0 }
5356 0 0       0 local $/ = undef; # slurp mode
5357 0         0 $script = <$fh>;
5358             if ($^O eq 'MacOS') {
5359             CORE::eval q{
5360             CORE::require Mac::Files;
5361             Mac::Files::FSpRstFLock("$realfilename.e");
5362 0 0       0 };
5363             }
5364             close($fh) or croak "Can't close file: $realfilename: $!";
5365 0         0 }
5366 0 0       0 else {
5367 0 0       0 my $fh = gensym();
    0          
5368 0         0 _open_r($fh, $realfilename) or croak "Can't open file: $realfilename";
5369             if ($^O eq 'MacOS') {
5370             CORE::eval q{
5371             CORE::require Mac::Files;
5372             Mac::Files::FSpSetFLock($realfilename);
5373             };
5374 0         0 }
5375 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5376 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5377             if ($@) {
5378             carp "Can't immediately read-lock the file: $realfilename";
5379             }
5380 0         0 }
5381             else {
5382 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5383 0         0 }
5384 0 0       0 local $/ = undef; # slurp mode
5385 0         0 $script = <$fh>;
5386             if ($^O eq 'MacOS') {
5387             CORE::eval q{
5388             CORE::require Mac::Files;
5389             Mac::Files::FSpRstFLock($realfilename);
5390 0 0       0 };
5391             }
5392 0 0       0 close($fh) or croak "Can't close file: $realfilename: $!";
5393 0         0  
5394 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) GBK (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5395 0         0 CORE::require GBK;
5396 0 0       0 $script = GBK::escape_script($script);
5397 0 0       0 my $fh = gensym();
    0          
5398 0         0 open($fh, ">$realfilename.e") or croak "Can't write open file: $realfilename.e";
5399             if ($^O eq 'MacOS') {
5400             CORE::eval q{
5401             CORE::require Mac::Files;
5402             Mac::Files::FSpSetFLock("$realfilename.e");
5403             };
5404 0         0 }
5405 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5406 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5407             if ($@) {
5408             carp "Can't immediately write-lock the file: $realfilename.e";
5409             }
5410 0         0 }
5411             else {
5412 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5413 0 0       0 }
5414 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5415 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5416 0         0 print {$fh} $script;
5417             if ($^O eq 'MacOS') {
5418             CORE::eval q{
5419             CORE::require Mac::Files;
5420             Mac::Files::FSpRstFLock("$realfilename.e");
5421 0 0       0 };
5422             }
5423             close($fh) or croak "Can't close file: $realfilename: $!";
5424             }
5425             }
5426 389     389   9859  
  389         724  
  389         363368  
  0         0  
5427 0         0 {
5428             no strict;
5429 0         0 $result = scalar CORE::eval $script;
5430             }
5431             last ITER_REQUIRE;
5432 0         0 }
5433             }
5434             croak "Can't find $_ in \@INC";
5435 0 0       0 }
    0          
5436 0         0  
5437 0         0 if ($@) {
5438             $INC{$_} = undef;
5439             croak $@;
5440 0         0 }
5441 0         0 elsif (not $result) {
5442             delete $INC{$_};
5443             croak "$_ did not return true value";
5444 0         0 }
5445             else {
5446             return $result;
5447             }
5448             }
5449              
5450             #
5451             # GBK telldir avoid warning
5452             #
5453 0     768 0 0 sub Egbk::telldir(*) {
5454              
5455 768         2124 local $^W = 0;
5456              
5457             return CORE::telldir $_[0];
5458             }
5459              
5460             #
5461             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
5462 768 0   0 0 31384 #
5463 0 0 0     0 sub Egbk::PREMATCH {
5464 0         0 if (defined($&)) {
5465             if (defined($1) and (CORE::substr($&,-CORE::length($1),CORE::length($1)) eq $1)) {
5466             return CORE::substr($&,0,CORE::length($&)-CORE::length($1));
5467 0         0 }
5468             else {
5469             croak 'Use of "$`", $PREMATCH, and ${^PREMATCH} need to /( capture all )/ in regexp';
5470             }
5471 0         0 }
5472             else {
5473 0         0 return '';
5474             }
5475             return $`;
5476             }
5477              
5478             #
5479             # ${^MATCH}, $MATCH, $& the string that matched
5480 0 0   0 0 0 #
5481 0 0       0 sub Egbk::MATCH {
5482 0         0 if (defined($&)) {
5483             if (defined($1)) {
5484             return $1;
5485 0         0 }
5486             else {
5487             croak 'Use of "$&", $MATCH, and ${^MATCH} need to /( capture all )/ in regexp';
5488             }
5489 0         0 }
5490             else {
5491 0         0 return '';
5492             }
5493             return $&;
5494             }
5495              
5496             #
5497             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
5498 0     0 0 0 #
5499             sub Egbk::POSTMATCH {
5500             return $';
5501             }
5502              
5503             #
5504             # GBK character to order (with parameter)
5505             #
5506 0 0   0 1 0 sub GBK::ord(;$) {
5507              
5508 0 0       0 local $_ = shift if @_;
5509 0         0  
5510 0         0 if (/\A ($q_char) /oxms) {
5511 0         0 my @ord = unpack 'C*', $1;
5512 0         0 my $ord = 0;
5513             while (my $o = shift @ord) {
5514 0         0 $ord = $ord * 0x100 + $o;
5515             }
5516             return $ord;
5517 0         0 }
5518             else {
5519             return CORE::ord $_;
5520             }
5521             }
5522              
5523             #
5524             # GBK character to order (without parameter)
5525             #
5526 0 0   0 0 0 sub GBK::ord_() {
5527 0         0  
5528 0         0 if (/\A ($q_char) /oxms) {
5529 0         0 my @ord = unpack 'C*', $1;
5530 0         0 my $ord = 0;
5531             while (my $o = shift @ord) {
5532 0         0 $ord = $ord * 0x100 + $o;
5533             }
5534             return $ord;
5535 0         0 }
5536             else {
5537             return CORE::ord $_;
5538             }
5539             }
5540              
5541             #
5542             # GBK reverse
5543             #
5544 0 0   0 0 0 sub GBK::reverse(@) {
5545 0         0  
5546             if (wantarray) {
5547             return CORE::reverse @_;
5548             }
5549             else {
5550              
5551             # One of us once cornered Larry in an elevator and asked him what
5552             # problem he was solving with this, but he looked as far off into
5553             # the distance as he could in an elevator and said, "It seemed like
5554 0         0 # a good idea at the time."
5555              
5556             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
5557             }
5558             }
5559              
5560             #
5561             # GBK getc (with parameter, without parameter)
5562             #
5563 0     0 0 0 sub GBK::getc(;*@) {
5564 0 0       0  
5565 0 0 0     0 my($package) = caller;
5566             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
5567 0         0 croak 'Too many arguments for GBK::getc' if @_ and not wantarray;
  0         0  
5568 0         0  
5569 0         0 my @length = sort { $a <=> $b } keys %range_tr;
5570 0         0 my $getc = '';
5571 0 0       0 for my $length ($length[0] .. $length[-1]) {
5572 0 0       0 $getc .= CORE::getc($fh);
5573 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
5574             if ($getc =~ /\A ${Egbk::dot_s} \z/oxms) {
5575             return wantarray ? ($getc,@_) : $getc;
5576             }
5577 0 0       0 }
5578             }
5579             return wantarray ? ($getc,@_) : $getc;
5580             }
5581              
5582             #
5583             # GBK length by character
5584             #
5585 0 0   0 1 0 sub GBK::length(;$) {
5586              
5587 0         0 local $_ = shift if @_;
5588 0         0  
5589             local @_ = /\G ($q_char) /oxmsg;
5590             return scalar @_;
5591             }
5592              
5593             #
5594             # GBK substr by character
5595             #
5596             BEGIN {
5597              
5598             # P.232 The lvalue Attribute
5599             # in Chapter 6: Subroutines
5600             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5601              
5602             # P.336 The lvalue Attribute
5603             # in Chapter 7: Subroutines
5604             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5605              
5606             # P.144 8.4 Lvalue subroutines
5607             # in Chapter 8: perlsub: Perl subroutines
5608 389 50 0 389 1 224568 # 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  
5609              
5610             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
5611             # vv----------------------*******
5612             sub GBK::substr($$;$$) %s {
5613              
5614             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5615              
5616             # If the substring is beyond either end of the string, substr() returns the undefined
5617             # value and produces a warning. When used as an lvalue, specifying a substring that
5618             # is entirely outside the string raises an exception.
5619             # http://perldoc.perl.org/functions/substr.html
5620              
5621             # A return with no argument returns the scalar value undef in scalar context,
5622             # an empty list () in list context, and (naturally) nothing at all in void
5623             # context.
5624              
5625             my $offset = $_[1];
5626             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
5627             return;
5628             }
5629              
5630             # substr($string,$offset,$length,$replacement)
5631             if (@_ == 4) {
5632             my(undef,undef,$length,$replacement) = @_;
5633             my $substr = join '', splice(@char, $offset, $length, $replacement);
5634             $_[0] = join '', @char;
5635              
5636             # return $substr; this doesn't work, don't say "return"
5637             $substr;
5638             }
5639              
5640             # substr($string,$offset,$length)
5641             elsif (@_ == 3) {
5642             my(undef,undef,$length) = @_;
5643             my $octet_offset = 0;
5644             my $octet_length = 0;
5645             if ($offset == 0) {
5646             $octet_offset = 0;
5647             }
5648             elsif ($offset > 0) {
5649             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5650             }
5651             else {
5652             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5653             }
5654             if ($length == 0) {
5655             $octet_length = 0;
5656             }
5657             elsif ($length > 0) {
5658             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
5659             }
5660             else {
5661             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
5662             }
5663             CORE::substr($_[0], $octet_offset, $octet_length);
5664             }
5665              
5666             # substr($string,$offset)
5667             else {
5668             my $octet_offset = 0;
5669             if ($offset == 0) {
5670             $octet_offset = 0;
5671             }
5672             elsif ($offset > 0) {
5673             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5674             }
5675             else {
5676             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5677             }
5678             CORE::substr($_[0], $octet_offset);
5679             }
5680             }
5681             END
5682             }
5683              
5684             #
5685             # GBK index by character
5686             #
5687 0     0 1 0 sub GBK::index($$;$) {
5688 0 0       0  
5689 0         0 my $index;
5690             if (@_ == 3) {
5691             $index = Egbk::index($_[0], $_[1], CORE::length(GBK::substr($_[0], 0, $_[2])));
5692 0         0 }
5693             else {
5694             $index = Egbk::index($_[0], $_[1]);
5695 0 0       0 }
5696 0         0  
5697             if ($index == -1) {
5698             return -1;
5699 0         0 }
5700             else {
5701             return GBK::length(CORE::substr $_[0], 0, $index);
5702             }
5703             }
5704              
5705             #
5706             # GBK rindex by character
5707             #
5708 0     0 1 0 sub GBK::rindex($$;$) {
5709 0 0       0  
5710 0         0 my $rindex;
5711             if (@_ == 3) {
5712             $rindex = Egbk::rindex($_[0], $_[1], CORE::length(GBK::substr($_[0], 0, $_[2])));
5713 0         0 }
5714             else {
5715             $rindex = Egbk::rindex($_[0], $_[1]);
5716 0 0       0 }
5717 0         0  
5718             if ($rindex == -1) {
5719             return -1;
5720 0         0 }
5721             else {
5722             return GBK::length(CORE::substr $_[0], 0, $rindex);
5723             }
5724             }
5725              
5726 389     389   2947 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  389         2414  
  389         40496  
5727             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
5728             use vars qw($slash); $slash = 'm//';
5729              
5730             # ord() to ord() or GBK::ord()
5731             my $function_ord = 'ord';
5732              
5733             # ord to ord or GBK::ord_
5734             my $function_ord_ = 'ord';
5735              
5736             # reverse to reverse or GBK::reverse
5737             my $function_reverse = 'reverse';
5738              
5739             # getc to getc or GBK::getc
5740             my $function_getc = 'getc';
5741              
5742             # P.1023 Appendix W.9 Multibyte Anchoring
5743             # of ISBN 1-56592-224-7 CJKV Information Processing
5744              
5745             my $anchor = '';
5746 389     389   5313 $anchor = q{${Egbk::anchor}};
  389     0   2230  
  389         22165062  
5747              
5748             use vars qw($nest);
5749              
5750             # regexp of nested parens in qqXX
5751              
5752             # P.340 Matching Nested Constructs with Embedded Code
5753             # in Chapter 7: Perl
5754             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5755              
5756             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
5757             [^\x81-\xFE\\()] |
5758             \( (?{$nest++}) |
5759             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5760             [\x81-\xFE][\x00-\xFF] |
5761             \\ [^\x81-\xFEc] |
5762             \\c[\x40-\x5F] |
5763             \\ [\x81-\xFE][\x00-\xFF] |
5764             [\x00-\xFF]
5765             }xms;
5766              
5767             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
5768             [^\x81-\xFE\\{}] |
5769             \{ (?{$nest++}) |
5770             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5771             [\x81-\xFE][\x00-\xFF] |
5772             \\ [^\x81-\xFEc] |
5773             \\c[\x40-\x5F] |
5774             \\ [\x81-\xFE][\x00-\xFF] |
5775             [\x00-\xFF]
5776             }xms;
5777              
5778             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
5779             [^\x81-\xFE\\\[\]] |
5780             \[ (?{$nest++}) |
5781             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5782             [\x81-\xFE][\x00-\xFF] |
5783             \\ [^\x81-\xFEc] |
5784             \\c[\x40-\x5F] |
5785             \\ [\x81-\xFE][\x00-\xFF] |
5786             [\x00-\xFF]
5787             }xms;
5788              
5789             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
5790             [^\x81-\xFE\\<>] |
5791             \< (?{$nest++}) |
5792             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5793             [\x81-\xFE][\x00-\xFF] |
5794             \\ [^\x81-\xFEc] |
5795             \\c[\x40-\x5F] |
5796             \\ [\x81-\xFE][\x00-\xFF] |
5797             [\x00-\xFF]
5798             }xms;
5799              
5800             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
5801             (?: ::)? (?:
5802             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5803             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5804             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5805             ))
5806             }xms;
5807              
5808             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
5809             (?: ::)? (?:
5810             (?>[0-9]+) |
5811             [^\x81-\xFEa-zA-Z_0-9\[\]] |
5812             ^[A-Z] |
5813             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5814             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5815             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5816             ))
5817             }xms;
5818              
5819             my $qq_substr = qr{(?> Char::substr | GBK::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
5820             }xms;
5821              
5822             # regexp of nested parens in qXX
5823             my $q_paren = qr{(?{local $nest=0}) (?>(?:
5824             [^\x81-\xFE()] |
5825             [\x81-\xFE][\x00-\xFF] |
5826             \( (?{$nest++}) |
5827             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5828             [\x00-\xFF]
5829             }xms;
5830              
5831             my $q_brace = qr{(?{local $nest=0}) (?>(?:
5832             [^\x81-\xFE\{\}] |
5833             [\x81-\xFE][\x00-\xFF] |
5834             \{ (?{$nest++}) |
5835             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5836             [\x00-\xFF]
5837             }xms;
5838              
5839             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
5840             [^\x81-\xFE\[\]] |
5841             [\x81-\xFE][\x00-\xFF] |
5842             \[ (?{$nest++}) |
5843             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5844             [\x00-\xFF]
5845             }xms;
5846              
5847             my $q_angle = qr{(?{local $nest=0}) (?>(?:
5848             [^\x81-\xFE<>] |
5849             [\x81-\xFE][\x00-\xFF] |
5850             \< (?{$nest++}) |
5851             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5852             [\x00-\xFF]
5853             }xms;
5854              
5855             my $matched = '';
5856             my $s_matched = '';
5857             $matched = q{$Egbk::matched};
5858             $s_matched = q{ Egbk::s_matched();};
5859              
5860             my $tr_variable = ''; # variable of tr///
5861             my $sub_variable = ''; # variable of s///
5862             my $bind_operator = ''; # =~ or !~
5863              
5864             my @heredoc = (); # here document
5865             my @heredoc_delimiter = ();
5866             my $here_script = ''; # here script
5867              
5868             #
5869             # escape GBK script
5870 0 50   384 0 0 #
5871             sub GBK::escape(;$) {
5872             local($_) = $_[0] if @_;
5873              
5874             # P.359 The Study Function
5875             # in Chapter 7: Perl
5876 384         1226 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5877              
5878             study $_; # Yes, I studied study yesterday.
5879              
5880             # while all script
5881              
5882             # 6.14. Matching from Where the Last Pattern Left Off
5883             # in Chapter 6. Pattern Matching
5884             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
5885             # (and so on)
5886              
5887             # one member of Tag-team
5888             #
5889             # P.128 Start of match (or end of previous match): \G
5890             # P.130 Advanced Use of \G with Perl
5891             # in Chapter 3: Overview of Regular Expression Features and Flavors
5892             # P.255 Use leading anchors
5893             # P.256 Expose ^ and \G at the front expressions
5894             # in Chapter 6: Crafting an Efficient Expression
5895             # P.315 "Tag-team" matching with /gc
5896             # in Chapter 7: Perl
5897 384         1014 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5898 384         712  
5899 384         1431 my $e_script = '';
5900             while (not /\G \z/oxgc) { # member
5901             $e_script .= GBK::escape_token();
5902 186412         278636 }
5903              
5904             return $e_script;
5905             }
5906              
5907             #
5908             # escape GBK token of script
5909             #
5910             sub GBK::escape_token {
5911              
5912 384     186412 0 5683 # \n output here document
5913              
5914             my $ignore_modules = join('|', qw(
5915             utf8
5916             bytes
5917             charnames
5918             I18N::Japanese
5919             I18N::Collate
5920             I18N::JExt
5921             File::DosGlob
5922             Wild
5923             Wildcard
5924             Japanese
5925             ));
5926              
5927             # another member of Tag-team
5928             #
5929             # P.315 "Tag-team" matching with /gc
5930             # in Chapter 7: Perl
5931 186412 100 100     219858 # 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          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    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          
5932 186412         13837638  
5933 31404 100       38405 if (/\G ( \n ) /oxgc) { # another member (and so on)
5934 31404         65001 my $heredoc = '';
5935             if (scalar(@heredoc_delimiter) >= 1) {
5936 197         258 $slash = 'm//';
5937 197         404  
5938             $heredoc = join '', @heredoc;
5939             @heredoc = ();
5940 197         329  
5941 197         346 # skip here document
5942             for my $heredoc_delimiter (@heredoc_delimiter) {
5943 205         1271 /\G .*? \n $heredoc_delimiter \n/xmsgc;
5944             }
5945 197         344 @heredoc_delimiter = ();
5946              
5947 197         251 $here_script = '';
5948             }
5949             return "\n" . $heredoc;
5950             }
5951 31404         90358  
5952             # ignore space, comment
5953             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
5954              
5955             # if (, elsif (, unless (, while (, until (, given (, and when (
5956              
5957             # given, when
5958              
5959             # P.225 The given Statement
5960             # in Chapter 15: Smart Matching and given-when
5961             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5962              
5963             # P.133 The given Statement
5964             # in Chapter 4: Statements and Declarations
5965             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5966 42620         127429  
5967 3773         5506 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
5968             $slash = 'm//';
5969             return $1;
5970             }
5971              
5972             # scalar variable ($scalar = ...) =~ tr///;
5973             # scalar variable ($scalar = ...) =~ s///;
5974              
5975             # state
5976              
5977             # P.68 Persistent, Private Variables
5978             # in Chapter 4: Subroutines
5979             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5980              
5981             # P.160 Persistent Lexically Scoped Variables: state
5982             # in Chapter 4: Statements and Declarations
5983             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5984              
5985             # (and so on)
5986 3773         11400  
5987             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
5988 170 50       463 my $e_string = e_string($1);
    50          
5989 170         6188  
5990 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
5991 0         0 $tr_variable = $e_string . e_string($1);
5992 0         0 $bind_operator = $2;
5993             $slash = 'm//';
5994             return '';
5995 0         0 }
5996 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
5997 0         0 $sub_variable = $e_string . e_string($1);
5998 0         0 $bind_operator = $2;
5999             $slash = 'm//';
6000             return '';
6001 0         0 }
6002 170         357 else {
6003             $slash = 'div';
6004             return $e_string;
6005             }
6006             }
6007              
6008 170         632 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egbk::PREMATCH()
6009 4         10 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
6010             $slash = 'div';
6011             return q{Egbk::PREMATCH()};
6012             }
6013              
6014 4         13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egbk::MATCH()
6015 28         54 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
6016             $slash = 'div';
6017             return q{Egbk::MATCH()};
6018             }
6019              
6020 28         102 # $', ${'} --> $', ${'}
6021 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
6022             $slash = 'div';
6023             return $1;
6024             }
6025              
6026 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egbk::POSTMATCH()
6027 3         7 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
6028             $slash = 'div';
6029             return q{Egbk::POSTMATCH()};
6030             }
6031              
6032             # scalar variable $scalar =~ tr///;
6033             # scalar variable $scalar =~ s///;
6034             # substr() =~ tr///;
6035 3         12 # substr() =~ s///;
6036             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
6037 2878 100       6300 my $scalar = e_string($1);
    100          
6038 2878         15360  
6039 9         17 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6040 9         16 $tr_variable = $scalar;
6041 9         13 $bind_operator = $1;
6042             $slash = 'm//';
6043             return '';
6044 9         25 }
6045 253         413 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6046 253         434 $sub_variable = $scalar;
6047 253         330 $bind_operator = $1;
6048             $slash = 'm//';
6049             return '';
6050 253         702 }
6051 2616         3719 else {
6052             $slash = 'div';
6053             return $scalar;
6054             }
6055             }
6056              
6057 2616         6757 # end of statement
6058             elsif (/\G ( [,;] ) /oxgc) {
6059             $slash = 'm//';
6060 12209         17827  
6061             # clear tr/// variable
6062             $tr_variable = '';
6063 12209         13929  
6064             # clear s/// variable
6065 12209         13342 $sub_variable = '';
6066              
6067 12209         12966 $bind_operator = '';
6068              
6069             return $1;
6070             }
6071              
6072 12209         39969 # bareword
6073             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
6074             return $1;
6075             }
6076              
6077 0         0 # $0 --> $0
6078 2         6 elsif (/\G ( \$ 0 ) /oxmsgc) {
6079             $slash = 'div';
6080             return $1;
6081 2         8 }
6082 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
6083             $slash = 'div';
6084             return $1;
6085             }
6086              
6087 0         0 # $$ --> $$
6088 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
6089             $slash = 'div';
6090             return $1;
6091             }
6092              
6093             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6094 1         10 # $1, $2, $3 --> $1, $2, $3 otherwise
6095 219         375 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
6096             $slash = 'div';
6097             return e_capture($1);
6098 219         478 }
6099 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
6100             $slash = 'div';
6101             return e_capture($1);
6102             }
6103              
6104 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6105 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
6106             $slash = 'div';
6107             return e_capture($1.'->'.$2);
6108             }
6109              
6110 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6111 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
6112             $slash = 'div';
6113             return e_capture($1.'->'.$2);
6114             }
6115              
6116 0         0 # $$foo
6117 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
6118             $slash = 'div';
6119             return e_capture($1);
6120             }
6121              
6122 0         0 # ${ foo }
6123 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
6124             $slash = 'div';
6125             return '${' . $1 . '}';
6126             }
6127              
6128 0         0 # ${ ... }
6129 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
6130             $slash = 'div';
6131             return e_capture($1);
6132             }
6133              
6134             # variable or function
6135 0         0 # $ @ % & * $ #
6136 605         909 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) {
6137             $slash = 'div';
6138             return $1;
6139             }
6140             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
6141 605         1951 # $ @ # \ ' " / ? ( ) [ ] < >
6142 103         353 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
6143             $slash = 'div';
6144             return $1;
6145             }
6146              
6147 103         367 # while ()
6148             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
6149             return $1;
6150             }
6151              
6152             # while () --- glob
6153              
6154             # avoid "Error: Runtime exception" of perl version 5.005_03
6155 0         0  
6156             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][\x00-\xFF])+?) > (?>\s*) \) \b /oxgc) {
6157             return 'while ($_ = Egbk::glob("' . $1 . '"))';
6158             }
6159              
6160 0         0 # while (glob)
6161             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
6162             return 'while ($_ = Egbk::glob_)';
6163             }
6164              
6165 0         0 # while (glob(WILDCARD))
6166             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
6167             return 'while ($_ = Egbk::glob';
6168             }
6169 0         0  
  482         1088  
6170             # doit if, doit unless, doit while, doit until, doit for, doit when
6171             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
6172 482         1880  
  19         35  
6173 19         63 # subroutines of package Egbk
  0         0  
6174 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         22  
6175 13         34 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
6176 0         0 elsif (/\G \b GBK::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         169  
6177 114         298 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         5  
6178 2         6 elsif (/\G \b GBK::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval GBK::escape'; }
  2         3  
6179 2         31 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
6180 2         7 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::chop'; }
  0         0  
6181 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         4  
6182 2         6 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  2         7  
6183 2         8 elsif (/\G \b GBK::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'GBK::index'; }
  2         6  
6184 2         5 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::index'; }
  0         0  
6185 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         5  
6186 2         13 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  2         6  
6187 2         8 elsif (/\G \b GBK::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'GBK::rindex'; }
  1         3  
6188 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::rindex'; }
  0         0  
6189 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egbk::lc'; }
  0         0  
6190 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egbk::lcfirst'; }
  0         0  
6191 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egbk::uc'; }
  3         6  
6192             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egbk::ucfirst'; }
6193             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egbk::fc'; }
6194              
6195             # stacked file test operators
6196              
6197             # P.179 File Test Operators
6198             # in Chapter 12: File Tests
6199             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6200              
6201             # P.106 Named Unary and File Test Operators
6202             # in Chapter 3: Unary and Binary Operators
6203             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6204              
6205             # (and so on)
6206 3         11  
  0         0  
6207 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6208 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6209 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6210 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6211 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6212 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  1         3  
6213             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6214             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6215 1         5  
  5         11  
6216 5         21 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6217 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6218 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6219 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6220 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6221 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  1         2  
6222             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6223             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6224 1         6  
  0         0  
6225 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6226 0         0 { $slash = 'm//'; return "Egbk::filetest(qw($1),$2)"; }
  0         0  
6227 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1),$2)"; }
  0         0  
6228             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $slash = 'm//'; return "Egbk::filetest qw($1),"; }
6229 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Egbk::filetest(qw($1),$2)"; }
  0         0  
6230 0         0  
  0         0  
6231 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6232 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6233 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6234 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6235 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  2         4  
6236             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
6237 2         7 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  103         217  
6238 103         331  
  0         0  
6239 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6240 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6241 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6242 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6243 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  2         4  
6244             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6245             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6246 2         26  
  6         12  
6247 6         27 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6248 0         0 { $slash = 'm//'; return "Egbk::$1($2)"; }
  0         0  
6249 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Egbk::$1($2)"; }
  50         104  
6250 50         268 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return "Egbk::$1"; }
  2         10  
6251 2         12 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Egbk::$1(::"."$2)"; }
  1         3  
6252 1         3 elsif (/\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-t $2"; }
  3         7  
6253             elsif (/\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egbk::lstat'; }
6254             elsif (/\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egbk::stat'; }
6255 3         12  
  0         0  
6256 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
6257 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
6258 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6259 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6260 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6261 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6262             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
6263 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  
6264 0         0  
  0         0  
6265 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
6266 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6267 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6268 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6269 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6270             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6271             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6272 0         0  
  0         0  
6273 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6274 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
6275 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
6276             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
6277 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         6  
6278 2         7  
  2         5  
6279 2         8 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         67  
6280 36         134 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
6281 2         7 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egbk::chr'; }
  2         7  
6282 2         9 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  8         21  
6283 8         35 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
6284 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egbk::glob'; }
  0         0  
6285 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::lc_'; }
  0         0  
6286 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::lcfirst_'; }
  0         0  
6287 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::uc_'; }
  0         0  
6288 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::ucfirst_'; }
  0         0  
6289 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::fc_'; }
  0         0  
6290             elsif (/\G \b lstat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::lstat_'; }
6291 0         0 elsif (/\G \b stat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::stat_'; }
  0         0  
6292             elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
6293 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Egbk::filetest_(qw($1))"; }
  0         0  
6294             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC])
6295 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Egbk::${1}_"; }
  0         0  
6296              
6297 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
6298 0         0  
  0         0  
6299 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
6300 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
6301 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::chr_'; }
  2         5  
6302 2         8 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
6303 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  4         10  
6304 4         16 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::glob_'; }
  8         23  
6305 8         33 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  2         7  
6306 2         14 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0         0  
6307 0         0 elsif (/\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Egbk::opendir$1*"; }
  87         248  
6308             elsif (/\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Egbk::opendir$1*"; }
6309             elsif (/\G \b unlink \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egbk::unlink'; }
6310              
6311 87         344 # chdir
6312             elsif (/\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
6313 3         7 $slash = 'm//';
6314              
6315 3         5 my $e = 'Egbk::chdir';
6316 3         11  
6317             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6318             $e .= $1;
6319             }
6320 3 50       13  
  3 100       216  
    50          
    50          
    50          
    0          
6321             # end of chdir
6322             if (/\G (?= [,;\)\}\]] ) /oxgc) { return $e; }
6323 0         0  
6324             # chdir scalar value
6325             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return $e . e_string($1); }
6326              
6327 1 0       4 # chdir qq//
  0         0  
6328             elsif (/\G \b (qq) \b /oxgc) {
6329 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq# # --> qr # #
6330 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6331 0         0 while (not /\G \z/oxgc) {
6332 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6333 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq ( ) --> qr ( )
6334 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq { } --> qr { }
6335 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq [ ] --> qr [ ]
6336 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq < > --> qr < >
6337             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq','{','}',$2); } # qq | | --> qr { }
6338 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq * * --> qr * *
6339             }
6340             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6341             }
6342             }
6343              
6344 0 0       0 # chdir q//
  0         0  
6345             elsif (/\G \b (q) \b /oxgc) {
6346 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q# # --> qr # #
6347 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6348 0         0 while (not /\G \z/oxgc) {
6349 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6350 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q ( ) --> qr ( )
6351 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q { } --> qr { }
6352 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q [ ] --> qr [ ]
6353 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q < > --> qr < >
6354             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q','{','}',$2); } # q | | --> qr { }
6355 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q * * --> qr * *
6356             }
6357             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6358             }
6359             }
6360              
6361 0         0 # chdir ''
6362 2         6 elsif (/\G (\') /oxgc) {
6363 2 50       6 my $q_string = '';
  13 50       64  
    100          
    50          
6364 0         0 while (not /\G \z/oxgc) {
6365 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6366 2         6 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
6367             elsif (/\G \' /oxgc) { return $e . e_chdir_q('',"'","'",$q_string); }
6368 11         25 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6369             }
6370             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6371             }
6372              
6373 0         0 # chdir ""
6374 0         0 elsif (/\G (\") /oxgc) {
6375 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6376 0         0 while (not /\G \z/oxgc) {
6377 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6378 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
6379             elsif (/\G \" /oxgc) { return $e . e_chdir('','"','"',$qq_string); }
6380 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6381             }
6382             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6383             }
6384             }
6385              
6386 0         0 # split
6387             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
6388 404         856 $slash = 'm//';
6389 404         560  
6390 404         1329 my $e = '';
6391             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6392             $e .= $1;
6393             }
6394 401 100       1502  
  404 100       36892  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
6395             # end of split
6396             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Egbk::split' . $e; }
6397 3         17  
6398             # split scalar value
6399             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Egbk::split' . $e . e_string($1); }
6400 1         6  
6401 0         0 # split literal space
6402 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Egbk::split' . $e . qq {qq$1 $2}; }
6403 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Egbk::split' . $e . qq{$1qq$2 $3}; }
6404 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Egbk::split' . $e . qq{$1qq$2 $3}; }
6405 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Egbk::split' . $e . qq{$1qq$2 $3}; }
6406 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Egbk::split' . $e . qq{$1qq$2 $3}; }
6407 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Egbk::split' . $e . qq{$1qq$2 $3}; }
6408 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Egbk::split' . $e . qq {q$1 $2}; }
6409 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Egbk::split' . $e . qq {$1q$2 $3}; }
6410 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Egbk::split' . $e . qq {$1q$2 $3}; }
6411 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Egbk::split' . $e . qq {$1q$2 $3}; }
6412 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Egbk::split' . $e . qq {$1q$2 $3}; }
6413 13         56 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Egbk::split' . $e . qq {$1q$2 $3}; }
6414             elsif (/\G ' [ ] ' /oxgc) { return 'Egbk::split' . $e . qq {' '}; }
6415             elsif (/\G " [ ] " /oxgc) { return 'Egbk::split' . $e . qq {" "}; }
6416              
6417 2 0       11 # split qq//
  0         0  
6418             elsif (/\G \b (qq) \b /oxgc) {
6419 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
6420 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6421 0         0 while (not /\G \z/oxgc) {
6422 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6423 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
6424 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
6425 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
6426 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
6427             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
6428 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
6429             }
6430             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6431             }
6432             }
6433              
6434 0 50       0 # split qr//
  124         815  
6435             elsif (/\G \b (qr) \b /oxgc) {
6436 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
6437 124 50       343 else {
  124 50       5726  
    50          
    50          
    50          
    100          
    50          
    50          
6438 0         0 while (not /\G \z/oxgc) {
6439 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6440 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
6441 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
6442 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
6443 56         250 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
6444 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
6445             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
6446 68         267 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
6447             }
6448             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6449             }
6450             }
6451              
6452 0 0       0 # split q//
  0         0  
6453             elsif (/\G \b (q) \b /oxgc) {
6454 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
6455 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6456 0         0 while (not /\G \z/oxgc) {
6457 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6458 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
6459 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
6460 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
6461 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
6462             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
6463 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
6464             }
6465             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6466             }
6467             }
6468              
6469 0 50       0 # split m//
  136         976  
6470             elsif (/\G \b (m) \b /oxgc) {
6471 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
6472 136 50       349 else {
  136 50       6217  
    50          
    50          
    50          
    100          
    50          
    50          
6473 0         0 while (not /\G \z/oxgc) {
6474 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6475 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
6476 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
6477 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
6478 56         187 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
6479 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
6480             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
6481 80         337 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
6482             }
6483             die __FILE__, ": Search pattern not terminated\n";
6484             }
6485             }
6486              
6487 0         0 # split ''
6488 0         0 elsif (/\G (\') /oxgc) {
6489 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6490 0         0 while (not /\G \z/oxgc) {
6491 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6492 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
6493             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
6494 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6495             }
6496             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6497             }
6498              
6499 0         0 # split ""
6500 0         0 elsif (/\G (\") /oxgc) {
6501 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6502 0         0 while (not /\G \z/oxgc) {
6503 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6504 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
6505             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
6506 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6507             }
6508             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6509             }
6510              
6511 0         0 # split //
6512 125         267 elsif (/\G (\/) /oxgc) {
6513 125 50       323 my $regexp = '';
  558 50       2545  
    100          
    50          
6514 0         0 while (not /\G \z/oxgc) {
6515 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
6516 125         481 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
6517             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
6518 433         924 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
6519             }
6520             die __FILE__, ": Search pattern not terminated\n";
6521             }
6522             }
6523              
6524             # tr/// or y///
6525              
6526             # about [cdsrbB]* (/B modifier)
6527             #
6528             # P.559 appendix C
6529             # of ISBN 4-89052-384-7 Programming perl
6530             # (Japanese title is: Perl puroguramingu)
6531 0         0  
6532             elsif (/\G \b ( tr | y ) \b /oxgc) {
6533             my $ope = $1;
6534 11 50       33  
6535 11         199 # $1 $2 $3 $4 $5 $6
6536 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
6537             my @tr = ($tr_variable,$2);
6538             return e_tr(@tr,'',$4,$6);
6539 0         0 }
6540 11         21 else {
6541 11 50       34 my $e = '';
  11 50       783  
    50          
    50          
    50          
    50          
6542             while (not /\G \z/oxgc) {
6543 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6544 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6545 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6546 0         0 while (not /\G \z/oxgc) {
6547 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6548 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
6549 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
6550 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
6551             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
6552 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
6553             }
6554             die __FILE__, ": Transliteration replacement not terminated\n";
6555 0         0 }
6556 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6557 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6558 0         0 while (not /\G \z/oxgc) {
6559 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6560 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
6561 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
6562 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
6563             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
6564 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
6565             }
6566             die __FILE__, ": Transliteration replacement not terminated\n";
6567 0         0 }
6568 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6569 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6570 0         0 while (not /\G \z/oxgc) {
6571 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6572 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
6573 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
6574 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
6575             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
6576 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
6577             }
6578             die __FILE__, ": Transliteration replacement not terminated\n";
6579 0         0 }
6580 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6581 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6582 0         0 while (not /\G \z/oxgc) {
6583 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6584 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
6585 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
6586 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
6587             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
6588 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
6589             }
6590             die __FILE__, ": Transliteration replacement not terminated\n";
6591             }
6592 0         0 # $1 $2 $3 $4 $5 $6
6593 11         40 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
6594             my @tr = ($tr_variable,$2);
6595             return e_tr(@tr,'',$4,$6);
6596 11         37 }
6597             }
6598             die __FILE__, ": Transliteration pattern not terminated\n";
6599             }
6600             }
6601              
6602 0         0 # qq//
6603             elsif (/\G \b (qq) \b /oxgc) {
6604             my $ope = $1;
6605 5897 100       19249  
6606 5897         10704 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
6607 40         182 if (/\G (\#) /oxgc) { # qq# #
6608 40 100       146 my $qq_string = '';
  1948 50       5885  
    100          
    50          
6609 80         153 while (not /\G \z/oxgc) {
6610 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6611 40         100 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
6612             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
6613 1828         3694 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6614             }
6615             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6616             }
6617 0         0  
6618 5857         7602 else {
6619 5857 50       14210 my $e = '';
  5857 50       21448  
    100          
    50          
    100          
    50          
6620             while (not /\G \z/oxgc) {
6621             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6622              
6623 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
6624 0         0 elsif (/\G (\() /oxgc) { # qq ( )
6625 0         0 my $qq_string = '';
6626 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6627 0         0 while (not /\G \z/oxgc) {
6628 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6629             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
6630 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6631 0         0 elsif (/\G (\)) /oxgc) {
6632             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
6633 0         0 else { $qq_string .= $1; }
6634             }
6635 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6636             }
6637             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6638             }
6639              
6640 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
6641 5775         7645 elsif (/\G (\{) /oxgc) { # qq { }
6642 5775         7823 my $qq_string = '';
6643 5775 100       12634 local $nest = 1;
  245875 50       741946  
    100          
    100          
    50          
6644 720         1389 while (not /\G \z/oxgc) {
6645 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1384         1920  
6646             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
6647 1384 100       2249 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  7159         10739  
6648 5775         12074 elsif (/\G (\}) /oxgc) {
6649             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
6650 1384         2697 else { $qq_string .= $1; }
6651             }
6652 236612         443037 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6653             }
6654             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6655             }
6656              
6657 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
6658 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
6659 0         0 my $qq_string = '';
6660 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6661 0         0 while (not /\G \z/oxgc) {
6662 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6663             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
6664 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6665 0         0 elsif (/\G (\]) /oxgc) {
6666             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
6667 0         0 else { $qq_string .= $1; }
6668             }
6669 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6670             }
6671             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6672             }
6673              
6674 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
6675 62         108 elsif (/\G (\<) /oxgc) { # qq < >
6676 62         104 my $qq_string = '';
6677 62 100       343 local $nest = 1;
  2040 50       7445  
    100          
    100          
    50          
6678 22         52 while (not /\G \z/oxgc) {
6679 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  2         3  
6680             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
6681 2 100       4 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  64         135  
6682 62         166 elsif (/\G (\>) /oxgc) {
6683             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
6684 2         4 else { $qq_string .= $1; }
6685             }
6686 1952         3731 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6687             }
6688             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6689             }
6690              
6691 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
6692 20         31 elsif (/\G (\S) /oxgc) { # qq * *
6693 20         23 my $delimiter = $1;
6694 20 50       37 my $qq_string = '';
  840 50       2655  
    100          
    50          
6695 0         0 while (not /\G \z/oxgc) {
6696 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6697 20         45 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
6698             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
6699 820         1918 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6700             }
6701             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6702 0         0 }
6703             }
6704             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6705             }
6706             }
6707              
6708 0         0 # qr//
6709 184 50       826 elsif (/\G \b (qr) \b /oxgc) {
6710 184         945 my $ope = $1;
6711             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
6712             return e_qr($ope,$1,$3,$2,$4);
6713 0         0 }
6714 184         271 else {
6715 184 50       568 my $e = '';
  184 50       5041  
    100          
    50          
    50          
    100          
    50          
    50          
6716 0         0 while (not /\G \z/oxgc) {
6717 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6718 1         6 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
6719 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
6720 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
6721 76         234 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
6722 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
6723             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
6724 107         356 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
6725             }
6726             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6727             }
6728             }
6729              
6730 0         0 # qw//
6731 34 50       96 elsif (/\G \b (qw) \b /oxgc) {
6732 34         99 my $ope = $1;
6733             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
6734             return e_qw($ope,$1,$3,$2);
6735 0         0 }
6736 34         52 else {
6737 34 50       109 my $e = '';
  34 50       190  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6738             while (not /\G \z/oxgc) {
6739 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6740 34         111  
6741             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6742 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6743 0         0  
6744             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6745 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6746 0         0  
6747             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6748 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6749 0         0  
6750             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6751 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6752 0         0  
6753             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6754 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6755             }
6756             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6757             }
6758             }
6759              
6760 0         0 # qx//
6761 3 50       9 elsif (/\G \b (qx) \b /oxgc) {
6762 3         71 my $ope = $1;
6763             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
6764             return e_qq($ope,$1,$3,$2);
6765 0         0 }
6766 3         7 else {
6767 3 50       12 my $e = '';
  3 50       387  
    100          
    50          
    50          
    50          
    50          
6768 0         0 while (not /\G \z/oxgc) {
6769 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6770 2         7 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
6771 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
6772 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
6773 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
6774             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
6775 1         5 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
6776             }
6777             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6778             }
6779             }
6780              
6781 0         0 # q//
6782             elsif (/\G \b (q) \b /oxgc) {
6783             my $ope = $1;
6784              
6785             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
6786              
6787             # avoid "Error: Runtime exception" of perl version 5.005_03
6788 606 50       1905 # (and so on)
6789 606         3270  
6790 0         0 if (/\G (\#) /oxgc) { # q# #
6791 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6792 0         0 while (not /\G \z/oxgc) {
6793 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6794 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
6795             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
6796 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6797             }
6798             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6799             }
6800 0         0  
6801 606         1176 else {
6802 606 50       2020 my $e = '';
  606 100       3667  
    100          
    50          
    100          
    50          
6803             while (not /\G \z/oxgc) {
6804             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6805              
6806 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
6807 1         3 elsif (/\G (\() /oxgc) { # q ( )
6808 1         2 my $q_string = '';
6809 1 50       3 local $nest = 1;
  7 50       56  
    50          
    50          
    100          
    50          
6810 0         0 while (not /\G \z/oxgc) {
6811 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6812 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
6813             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
6814 0 50       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  1         3  
6815 1         2 elsif (/\G (\)) /oxgc) {
6816             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
6817 0         0 else { $q_string .= $1; }
6818             }
6819 6         15 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6820             }
6821             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6822             }
6823              
6824 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
6825 599         1115 elsif (/\G (\{) /oxgc) { # q { }
6826 599         1422 my $q_string = '';
6827 599 50       1818 local $nest = 1;
  8189 50       35381  
    50          
    100          
    100          
    50          
6828 0         0 while (not /\G \z/oxgc) {
6829 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6830 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  114         167  
6831             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
6832 114 100       258 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  713         1559  
6833 599         1850 elsif (/\G (\}) /oxgc) {
6834             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
6835 114         229 else { $q_string .= $1; }
6836             }
6837 7362         14083 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6838             }
6839             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6840             }
6841              
6842 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
6843 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
6844 0         0 my $q_string = '';
6845 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
6846 0         0 while (not /\G \z/oxgc) {
6847 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6848 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
6849             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
6850 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
6851 0         0 elsif (/\G (\]) /oxgc) {
6852             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
6853 0         0 else { $q_string .= $1; }
6854             }
6855 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6856             }
6857             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6858             }
6859              
6860 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
6861 5         14 elsif (/\G (\<) /oxgc) { # q < >
6862 5         10 my $q_string = '';
6863 5 50       20 local $nest = 1;
  82 50       397  
    50          
    50          
    100          
    50          
6864 0         0 while (not /\G \z/oxgc) {
6865 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6866 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
6867             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
6868 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         16  
6869 5         17 elsif (/\G (\>) /oxgc) {
6870             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
6871 0         0 else { $q_string .= $1; }
6872             }
6873 77         151 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6874             }
6875             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6876             }
6877              
6878 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
6879 1         3 elsif (/\G (\S) /oxgc) { # q * *
6880 1         2 my $delimiter = $1;
6881 1 50       3 my $q_string = '';
  14 50       78  
    100          
    50          
6882 0         0 while (not /\G \z/oxgc) {
6883 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6884 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
6885             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
6886 13         24 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6887             }
6888             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6889 0         0 }
6890             }
6891             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6892             }
6893             }
6894              
6895 0         0 # m//
6896 491 50       1274 elsif (/\G \b (m) \b /oxgc) {
6897 491         2782 my $ope = $1;
6898             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
6899             return e_qr($ope,$1,$3,$2,$4);
6900 0         0 }
6901 491         710 else {
6902 491 50       1207 my $e = '';
  491 50       36211  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6903 0         0 while (not /\G \z/oxgc) {
6904 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6905 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
6906 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
6907 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
6908 92         252 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
6909 87         295 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
6910 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
6911             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
6912 312         1041 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
6913             }
6914             die __FILE__, ": Search pattern not terminated\n";
6915             }
6916             }
6917              
6918             # s///
6919              
6920             # about [cegimosxpradlunbB]* (/cg modifier)
6921             #
6922             # P.67 Pattern-Matching Operators
6923             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
6924 0         0  
6925             elsif (/\G \b (s) \b /oxgc) {
6926             my $ope = $1;
6927 290 100       856  
6928 290         4185 # $1 $2 $3 $4 $5 $6
6929             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
6930             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
6931 1         6 }
6932 289         501 else {
6933 289 50       978 my $e = '';
  289 50       28269  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6934             while (not /\G \z/oxgc) {
6935 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6936 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6937 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6938             while (not /\G \z/oxgc) {
6939 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6940 0         0 # $1 $2 $3 $4
6941 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6942 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6943 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6944 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6945 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([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             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6949 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6950             }
6951             die __FILE__, ": Substitution replacement not terminated\n";
6952 0         0 }
6953 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6954 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6955             while (not /\G \z/oxgc) {
6956 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6957 0         0 # $1 $2 $3 $4
6958 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6959 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6960 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6961 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6962 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([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             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6966 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6967             }
6968             die __FILE__, ": Substitution replacement not terminated\n";
6969 0         0 }
6970 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6971 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
6972             while (not /\G \z/oxgc) {
6973 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6974 0         0 # $1 $2 $3 $4
6975 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6976 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6977 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6978 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6979 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6980             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6981 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6982             }
6983             die __FILE__, ": Substitution replacement not terminated\n";
6984 0         0 }
6985 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6986 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6987             while (not /\G \z/oxgc) {
6988 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6989 0         0 # $1 $2 $3 $4
6990 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6991 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6992 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6993 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6994 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([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             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6998 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6999             }
7000             die __FILE__, ": Substitution replacement not terminated\n";
7001             }
7002 0         0 # $1 $2 $3 $4 $5 $6
7003             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
7004             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7005             }
7006 96         269 # $1 $2 $3 $4 $5 $6
7007             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7008             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
7009             }
7010 2         28 # $1 $2 $3 $4 $5 $6
7011             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7012             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7013             }
7014 0         0 # $1 $2 $3 $4 $5 $6
7015             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7016             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7017 191         762 }
7018             }
7019             die __FILE__, ": Substitution pattern not terminated\n";
7020             }
7021             }
7022 0         0  
7023 1         6 # do
7024 0         0 elsif (/\G \b do (?= (?>\s*) \{ ) /oxmsgc) { return 'do'; }
7025 0         0 elsif (/\G \b do (?= (?>\s+) (?: q | qq | qx ) \b) /oxmsgc) { return 'Egbk::do'; }
7026 0         0 elsif (/\G \b do (?= (?>\s+) (?>\w+)) /oxmsgc) { return 'do'; }
7027             elsif (/\G \b do (?= (?>\s*) \$ (?> \w+ (?: ::\w+)* ) \( ) /oxmsgc) { return 'do'; }
7028             elsif (/\G \b do \b /oxmsgc) { return 'Egbk::do'; }
7029 2         11  
7030 0         0 # require ignore module
7031 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
7032             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# require$1\n$2"; }
7033             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
7034 0         0  
7035 0         0 # require version number
7036 0         0 elsif (/\G \b require (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7037             elsif (/\G \b require (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7038             elsif (/\G \b require (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7039 0         0  
7040             # require bare package name
7041             elsif (/\G \b require (?>\s+) ((?>[A-Za-z_]\w* (?: :: [A-Za-z_]\w*)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7042 18         119  
7043 0         0 # require else
7044             elsif (/\G \b require (?>\s*) ; /oxmsgc) { return 'Egbk::require;'; }
7045             elsif (/\G \b require \b /oxmsgc) { return 'Egbk::require'; }
7046 1         5  
7047 70         600 # use strict; --> use strict; no strict qw(refs);
7048 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
7049             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
7050             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
7051              
7052 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
7053 3         45 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7054             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
7055             return "use $1; no strict qw(refs);";
7056 0         0 }
7057             else {
7058             return "use $1;";
7059             }
7060 3 0 0     20 }
      0        
7061 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7062             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
7063             return "use $1; no strict qw(refs);";
7064 0         0 }
7065             else {
7066             return "use $1;";
7067             }
7068             }
7069 0         0  
7070 2         16 # ignore use module
7071 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
7072             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# use$1\n$2"; }
7073             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
7074 0         0  
7075 0         0 # ignore no module
7076 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
7077             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# no$1\n$2"; }
7078             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
7079 0         0  
7080 0         0 # use without import
7081 0         0 elsif (/\G \b use (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7082 0         0 elsif (/\G \b use (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7083 0         0 elsif (/\G \b use (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7084 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7085 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\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             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7090             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7091 0         0  
7092             # use with import no parameter
7093             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_use_noparam($1); }
7094 0         0  
7095 0         0 # use with import parameters
7096 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
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+) ((?: q | qq | qw ) (?>\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*) (\{) (?:$q_char)*? \}) (?>\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*) (\<) [^\x81-\xFE>]* \>) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7103             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7104             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); }
7105 0         0  
7106 0         0 # no without unimport
7107 0         0 elsif (/\G \b no (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7108 0         0 elsif (/\G \b no (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7109 0         0 elsif (/\G \b no (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7110 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7111 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\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             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7116             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7117 0         0  
7118             # no with unimport no parameter
7119             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_no_noparam($1); }
7120 0         0  
7121 0         0 # no with unimport parameters
7122 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
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+) ((?: q | qq | qw ) (?>\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*) (\{) (?:$q_char)*? \}) (?>\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*) (\<) [^\x81-\xFE>]* \>) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7129             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7130             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); }
7131 0         0  
7132             # use else
7133             elsif (/\G \b use \b /oxmsgc) { return "use"; }
7134 0         0  
7135             # use else
7136             elsif (/\G \b no \b /oxmsgc) { return "no"; }
7137              
7138 2         11 # ''
7139 3177         7049 elsif (/\G (?
7140 3177 100       8873 my $q_string = '';
  15630 100       51837  
    100          
    50          
7141 8         20 while (not /\G \z/oxgc) {
7142 48         92 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
7143 3177         7653 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
7144             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
7145 12397         25918 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7146             }
7147             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7148             }
7149              
7150 0         0 # ""
7151 3404         8231 elsif (/\G (\") /oxgc) {
7152 3404 100       9123 my $qq_string = '';
  69438 100       195765  
    100          
    50          
7153 109         287 while (not /\G \z/oxgc) {
7154 14         27 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7155 3404         8377 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
7156             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
7157 65911         124813 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
7158             }
7159             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7160             }
7161              
7162 0         0 # ``
7163 37         105 elsif (/\G (\`) /oxgc) {
7164 37 50       162 my $qx_string = '';
  313 50       1743  
    100          
    50          
7165 0         0 while (not /\G \z/oxgc) {
7166 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
7167 37         138 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
7168             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
7169 276         619 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
7170             }
7171             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7172             }
7173              
7174 0         0 # // --- not divide operator (num / num), not defined-or
7175 1231         3039 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
7176 1231 100       3233 my $regexp = '';
  12602 50       41648  
    100          
    50          
7177 11         32 while (not /\G \z/oxgc) {
7178 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7179 1231         3386 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
7180             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
7181 11360         22219 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7182             }
7183             die __FILE__, ": Search pattern not terminated\n";
7184             }
7185              
7186 0         0 # ?? --- not conditional operator (condition ? then : else)
7187 92         207 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
7188 92 50       217 my $regexp = '';
  266 50       983  
    100          
    50          
7189 0         0 while (not /\G \z/oxgc) {
7190 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7191 92         217 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
7192             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
7193 174         437 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7194             }
7195             die __FILE__, ": Search pattern not terminated\n";
7196             }
7197 0         0  
  0         0  
7198             # <<>> (a safer ARGV)
7199             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
7200 0         0  
  0         0  
7201             # << (bit shift) --- not here document
7202             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
7203              
7204 0         0 # <<~'HEREDOC'
7205 6         13 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
7206 6         12 $slash = 'm//';
7207             my $here_quote = $1;
7208             my $delimiter = $2;
7209 6 50       7  
7210 6         14 # get here document
7211 6         37 if ($here_script eq '') {
7212             $here_script = CORE::substr $_, pos $_;
7213 6 50       30 $here_script =~ s/.*?\n//oxm;
7214 6         54 }
7215 6         12 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7216 6         10 my $heredoc = $1;
7217 6         48 my $indent = $2;
7218 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
7219             push @heredoc, $heredoc . qq{\n$delimiter\n};
7220             push @heredoc_delimiter, qq{\\s*$delimiter};
7221 6         12 }
7222             else {
7223 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7224             }
7225             return qq{<<'$delimiter'};
7226             }
7227              
7228             # <<~\HEREDOC
7229              
7230             # P.66 2.6.6. "Here" Documents
7231             # in Chapter 2: Bits and Pieces
7232             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7233              
7234             # P.73 "Here" Documents
7235             # in Chapter 2: Bits and Pieces
7236             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7237 6         23  
7238 3         7 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
7239 3         7 $slash = 'm//';
7240             my $here_quote = $1;
7241             my $delimiter = $2;
7242 3 50       4  
7243 3         8 # get here document
7244 3         12 if ($here_script eq '') {
7245             $here_script = CORE::substr $_, pos $_;
7246 3 50       16 $here_script =~ s/.*?\n//oxm;
7247 3         35 }
7248 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7249 3         4 my $heredoc = $1;
7250 3         33 my $indent = $2;
7251 3         11 $heredoc =~ s{^$indent}{}msg; # no /ox
7252             push @heredoc, $heredoc . qq{\n$delimiter\n};
7253             push @heredoc_delimiter, qq{\\s*$delimiter};
7254 3         5 }
7255             else {
7256 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7257             }
7258             return qq{<<\\$delimiter};
7259             }
7260              
7261 3         13 # <<~"HEREDOC"
7262 6         11 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
7263 6         22 $slash = 'm//';
7264             my $here_quote = $1;
7265             my $delimiter = $2;
7266 6 50       14  
7267 6         10 # get here document
7268 6         27 if ($here_script eq '') {
7269             $here_script = CORE::substr $_, pos $_;
7270 6 50       31 $here_script =~ s/.*?\n//oxm;
7271 6         59 }
7272 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7273 6         10 my $heredoc = $1;
7274 6         47 my $indent = $2;
7275 6         14 $heredoc =~ s{^$indent}{}msg; # no /ox
7276             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7277             push @heredoc_delimiter, qq{\\s*$delimiter};
7278 6         15 }
7279             else {
7280 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7281             }
7282             return qq{<<"$delimiter"};
7283             }
7284              
7285 6         23 # <<~HEREDOC
7286 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
7287 3         7 $slash = 'm//';
7288             my $here_quote = $1;
7289             my $delimiter = $2;
7290 3 50       7  
7291 3         8 # get here document
7292 3         13 if ($here_script eq '') {
7293             $here_script = CORE::substr $_, pos $_;
7294 3 50       15 $here_script =~ s/.*?\n//oxm;
7295 3         37 }
7296 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7297 3         4 my $heredoc = $1;
7298 3         33 my $indent = $2;
7299 3         11 $heredoc =~ s{^$indent}{}msg; # no /ox
7300             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7301             push @heredoc_delimiter, qq{\\s*$delimiter};
7302 3         8 }
7303             else {
7304 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7305             }
7306             return qq{<<$delimiter};
7307             }
7308              
7309 3         13 # <<~`HEREDOC`
7310 6         12 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
7311 6         11 $slash = 'm//';
7312             my $here_quote = $1;
7313             my $delimiter = $2;
7314 6 50       9  
7315 6         12 # get here document
7316 6         20 if ($here_script eq '') {
7317             $here_script = CORE::substr $_, pos $_;
7318 6 50       29 $here_script =~ s/.*?\n//oxm;
7319 6         60 }
7320 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7321 6         15 my $heredoc = $1;
7322 6         48 my $indent = $2;
7323 6         16 $heredoc =~ s{^$indent}{}msg; # no /ox
7324             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7325             push @heredoc_delimiter, qq{\\s*$delimiter};
7326 6         14 }
7327             else {
7328 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7329             }
7330             return qq{<<`$delimiter`};
7331             }
7332              
7333 6         25 # <<'HEREDOC'
7334 86         186 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
7335 86         181 $slash = 'm//';
7336             my $here_quote = $1;
7337             my $delimiter = $2;
7338 86 100       143  
7339 86         174 # get here document
7340 83         461 if ($here_script eq '') {
7341             $here_script = CORE::substr $_, pos $_;
7342 83 50       435 $here_script =~ s/.*?\n//oxm;
7343 86         641 }
7344 86         282 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7345             push @heredoc, $1 . qq{\n$delimiter\n};
7346             push @heredoc_delimiter, $delimiter;
7347 86         131 }
7348             else {
7349 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7350             }
7351             return $here_quote;
7352             }
7353              
7354             # <<\HEREDOC
7355              
7356             # P.66 2.6.6. "Here" Documents
7357             # in Chapter 2: Bits and Pieces
7358             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7359              
7360             # P.73 "Here" Documents
7361             # in Chapter 2: Bits and Pieces
7362             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7363 86         325  
7364 2         5 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
7365 2         4 $slash = 'm//';
7366             my $here_quote = $1;
7367             my $delimiter = $2;
7368 2 100       4  
7369 2         5 # get here document
7370 1         64 if ($here_script eq '') {
7371             $here_script = CORE::substr $_, pos $_;
7372 1 50       10 $here_script =~ s/.*?\n//oxm;
7373 2         27 }
7374 2         8 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7375             push @heredoc, $1 . qq{\n$delimiter\n};
7376             push @heredoc_delimiter, $delimiter;
7377 2         3 }
7378             else {
7379 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7380             }
7381             return $here_quote;
7382             }
7383              
7384 2         9 # <<"HEREDOC"
7385 39         110 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
7386 39         95 $slash = 'm//';
7387             my $here_quote = $1;
7388             my $delimiter = $2;
7389 39 100       69  
7390 39         99 # get here document
7391 38         233 if ($here_script eq '') {
7392             $here_script = CORE::substr $_, pos $_;
7393 38 50       215 $here_script =~ s/.*?\n//oxm;
7394 39         481 }
7395 39         134 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7396             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7397             push @heredoc_delimiter, $delimiter;
7398 39         84 }
7399             else {
7400 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7401             }
7402             return $here_quote;
7403             }
7404              
7405 39         159 # <
7406 54         141 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
7407 54         123 $slash = 'm//';
7408             my $here_quote = $1;
7409             my $delimiter = $2;
7410 54 100       102  
7411 54         157 # get here document
7412 51         307 if ($here_script eq '') {
7413             $here_script = CORE::substr $_, pos $_;
7414 51 50       386 $here_script =~ s/.*?\n//oxm;
7415 54         802 }
7416 54         185 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7417             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7418             push @heredoc_delimiter, $delimiter;
7419 54         123 }
7420             else {
7421 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7422             }
7423             return $here_quote;
7424             }
7425              
7426 54         221 # <<`HEREDOC`
7427 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
7428 0         0 $slash = 'm//';
7429             my $here_quote = $1;
7430             my $delimiter = $2;
7431 0 0       0  
7432 0         0 # get here document
7433 0         0 if ($here_script eq '') {
7434             $here_script = CORE::substr $_, pos $_;
7435 0 0       0 $here_script =~ s/.*?\n//oxm;
7436 0         0 }
7437 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7438             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7439             push @heredoc_delimiter, $delimiter;
7440 0         0 }
7441             else {
7442 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7443             }
7444             return $here_quote;
7445             }
7446              
7447 0         0 # <<= <=> <= < operator
7448             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
7449             return $1;
7450             }
7451              
7452 13         73 #
7453             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
7454             return $1;
7455             }
7456              
7457             # --- glob
7458              
7459             # avoid "Error: Runtime exception" of perl version 5.005_03
7460 0         0  
7461             elsif (/\G < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][\x00-\xFF])+?) > /oxgc) {
7462             return 'Egbk::glob("' . $1 . '")';
7463             }
7464 0         0  
7465             # __DATA__
7466             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
7467 0         0  
7468             # __END__
7469             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
7470              
7471             # \cD Control-D
7472              
7473             # P.68 2.6.8. Other Literal Tokens
7474             # in Chapter 2: Bits and Pieces
7475             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7476              
7477             # P.76 Other Literal Tokens
7478             # in Chapter 2: Bits and Pieces
7479 384         3218 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7480              
7481             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
7482 0         0  
7483             # \cZ Control-Z
7484             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
7485              
7486             # any operator before div
7487             elsif (/\G (
7488             -- | \+\+ |
7489 0         0 [\)\}\]]
  14161         29877  
7490              
7491             ) /oxgc) { $slash = 'div'; return $1; }
7492              
7493             # yada-yada or triple-dot operator
7494             elsif (/\G (
7495 14161         65472 \.\.\.
  7         14  
7496              
7497             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
7498              
7499             # any operator before m//
7500              
7501             # //, //= (defined-or)
7502              
7503             # P.164 Logical Operators
7504             # in Chapter 10: More Control Structures
7505             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7506              
7507             # P.119 C-Style Logical (Short-Circuit) Operators
7508             # in Chapter 3: Unary and Binary Operators
7509             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7510              
7511             # (and so on)
7512              
7513             # ~~
7514              
7515             # P.221 The Smart Match Operator
7516             # in Chapter 15: Smart Matching and given-when
7517             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7518              
7519             # P.112 Smartmatch Operator
7520             # in Chapter 3: Unary and Binary Operators
7521             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7522              
7523             # (and so on)
7524              
7525             elsif (/\G ((?>
7526              
7527             !~~ | !~ | != | ! |
7528             %= | % |
7529             &&= | && | &= | &\.= | &\. | & |
7530             -= | -> | - |
7531             :(?>\s*)= |
7532             : |
7533             <<>> |
7534             <<= | <=> | <= | < |
7535             == | => | =~ | = |
7536             >>= | >> | >= | > |
7537             \*\*= | \*\* | \*= | \* |
7538             \+= | \+ |
7539             \.\. | \.= | \. |
7540             \/\/= | \/\/ |
7541             \/= | \/ |
7542             \? |
7543             \\ |
7544             \^= | \^\.= | \^\. | \^ |
7545             \b x= |
7546             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
7547             ~~ | ~\. | ~ |
7548             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
7549             \b(?: print )\b |
7550              
7551 7         31 [,;\(\{\[]
  23792         48632  
7552              
7553             )) /oxgc) { $slash = 'm//'; return $1; }
7554 23792         109578  
  36888         72498  
7555             # other any character
7556             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
7557              
7558 36888         184137 # system error
7559             else {
7560             die __FILE__, ": Oops, this shouldn't happen!\n";
7561             }
7562             }
7563              
7564 0     3097 0 0 # escape GBK string
7565 3097         7188 sub e_string {
7566             my($string) = @_;
7567 3097         4303 my $e_string = '';
7568              
7569             local $slash = 'm//';
7570              
7571             # P.1024 Appendix W.10 Multibyte Processing
7572             # of ISBN 1-56592-224-7 CJKV Information Processing
7573 3097         4390 # (and so on)
7574              
7575             my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\$q_char|$q_char) /oxmsg;
7576 3097 100 66     26453  
7577 3097 50       14247 # without { ... }
7578 3018         6895 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
7579             if ($string !~ /<
7580             return $string;
7581             }
7582             }
7583 3018         7042  
7584 79 50       271 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          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    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          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
7585             while ($string !~ /\G \z/oxgc) {
7586             if (0) {
7587             }
7588 606         83017  
7589 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Egbk::PREMATCH()]}
7590 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
7591             $e_string .= q{Egbk::PREMATCH()};
7592             $slash = 'div';
7593             }
7594              
7595 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Egbk::MATCH()]}
7596 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
7597             $e_string .= q{Egbk::MATCH()};
7598             $slash = 'div';
7599             }
7600              
7601 0         0 # $', ${'} --> $', ${'}
7602 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
7603             $e_string .= $1;
7604             $slash = 'div';
7605             }
7606              
7607 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Egbk::POSTMATCH()]}
7608 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
7609             $e_string .= q{Egbk::POSTMATCH()};
7610             $slash = 'div';
7611             }
7612              
7613 0         0 # bareword
7614 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
7615             $e_string .= $1;
7616             $slash = 'div';
7617             }
7618              
7619 0         0 # $0 --> $0
7620 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
7621             $e_string .= $1;
7622             $slash = 'div';
7623 0         0 }
7624 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
7625             $e_string .= $1;
7626             $slash = 'div';
7627             }
7628              
7629 0         0 # $$ --> $$
7630 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
7631             $e_string .= $1;
7632             $slash = 'div';
7633             }
7634              
7635             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7636 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7637 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
7638             $e_string .= e_capture($1);
7639             $slash = 'div';
7640 0         0 }
7641 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
7642             $e_string .= e_capture($1);
7643             $slash = 'div';
7644             }
7645              
7646 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7647 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
7648             $e_string .= e_capture($1.'->'.$2);
7649             $slash = 'div';
7650             }
7651              
7652 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7653 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
7654             $e_string .= e_capture($1.'->'.$2);
7655             $slash = 'div';
7656             }
7657              
7658 0         0 # $$foo
7659 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
7660             $e_string .= e_capture($1);
7661             $slash = 'div';
7662             }
7663              
7664 0         0 # ${ foo }
7665 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
7666             $e_string .= '${' . $1 . '}';
7667             $slash = 'div';
7668             }
7669              
7670 0         0 # ${ ... }
7671 3         10 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
7672             $e_string .= e_capture($1);
7673             $slash = 'div';
7674             }
7675              
7676             # variable or function
7677 3         15 # $ @ % & * $ #
7678 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) {
7679             $e_string .= $1;
7680             $slash = 'div';
7681             }
7682             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
7683 0         0 # $ @ # \ ' " / ? ( ) [ ] < >
7684 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
7685             $e_string .= $1;
7686             $slash = 'div';
7687             }
7688 0         0  
  0         0  
7689 0         0 # subroutines of package Egbk
  0         0  
7690 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
7691 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7692 0         0 elsif ($string =~ /\G \b GBK::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7693 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
7694 0         0 elsif ($string =~ /\G \b GBK::eval \b /oxgc) { $e_string .= 'eval GBK::escape'; $slash = 'm//'; }
  0         0  
7695 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
7696 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Egbk::chop'; $slash = 'm//'; }
  0         0  
7697 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
7698 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
7699 0         0 elsif ($string =~ /\G \b GBK::index \b /oxgc) { $e_string .= 'GBK::index'; $slash = 'm//'; }
  0         0  
7700 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Egbk::index'; $slash = 'm//'; }
  0         0  
7701 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
7702 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
7703 0         0 elsif ($string =~ /\G \b GBK::rindex \b /oxgc) { $e_string .= 'GBK::rindex'; $slash = 'm//'; }
  0         0  
7704 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Egbk::rindex'; $slash = 'm//'; }
  0         0  
7705 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egbk::lc'; $slash = 'm//'; }
  0         0  
7706 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egbk::lcfirst'; $slash = 'm//'; }
  0         0  
7707 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egbk::uc'; $slash = 'm//'; }
  0         0  
7708             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egbk::ucfirst'; $slash = 'm//'; }
7709 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egbk::fc'; $slash = 'm//'; }
  0         0  
7710 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7711 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Egbk::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7712 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Egbk::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7713 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Egbk::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_brace)+?) (\}) /oxgc) { $e_string .= "Egbk::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_bracket)+?) (\]) /oxgc) { $e_string .= "Egbk::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         8  
7716             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Egbk::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7717             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Egbk::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7718 1         4  
  1         8  
7719 1         4 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7720 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Egbk::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7721 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Egbk::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7722 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Egbk::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_brace)+?) (\}) /oxgc) { $e_string .= "Egbk::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_bracket)+?) (\]) /oxgc) { $e_string .= "Egbk::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  1         8  
7725             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Egbk::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7726             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Egbk::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7727 1         4  
  0         0  
7728 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7729 0         0 { $e_string .= "Egbk::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7730 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Egbk::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7731             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $e_string .= "Egbk::filetest qw($1),"; $slash = 'm//'; }
7732 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $e_string .= "Egbk::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7733 0         0  
  0         0  
7734 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Egbk::$1(" . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7735 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7736 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7737 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7738 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  2         10  
7739             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7740 2         8 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Egbk::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         7  
7741 1         4  
  0         0  
7742 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Egbk::$1(" . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7743 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7744 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7745 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7746 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  2         30  
7747             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7748             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Egbk::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7749 2         8  
  0         0  
7750 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7751 0         0 { $e_string .= "Egbk::$1($2)"; $slash = 'm//'; }
  0         0  
7752 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Egbk::$1($2)"; $slash = 'm//'; }
  0         0  
7753 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= "Egbk::$1"; $slash = 'm//'; }
  0         0  
7754 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "Egbk::$1(::"."$2)"; $slash = 'm//'; }
  0         0  
7755 0         0 elsif ($string =~ /\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-t $2"; $slash = 'm//'; }
  0         0  
7756             elsif ($string =~ /\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egbk::lstat'; $slash = 'm//'; }
7757             elsif ($string =~ /\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egbk::stat'; $slash = 'm//'; }
7758 0         0  
  0         0  
7759 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
7760 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7761 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  
7762 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  
7763 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  
7764 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  
7765             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
7766 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  
7767 0         0  
  0         0  
7768 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7769 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  
7770 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  
7771 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  
7772 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  
7773             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7774             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7775 0         0  
  0         0  
7776 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
7777 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7778 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
7779             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
7780 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7781 0         0  
  0         0  
7782 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7783 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7784 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egbk::chr'; $slash = 'm//'; }
  0         0  
7785 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7786 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
7787 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egbk::glob'; $slash = 'm//'; }
  0         0  
7788 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Egbk::lc_'; $slash = 'm//'; }
  0         0  
7789 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Egbk::lcfirst_'; $slash = 'm//'; }
  0         0  
7790 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Egbk::uc_'; $slash = 'm//'; }
  0         0  
7791 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Egbk::ucfirst_'; $slash = 'm//'; }
  0         0  
7792 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Egbk::fc_'; $slash = 'm//'; }
  0         0  
7793             elsif ($string =~ /\G \b lstat \b /oxgc) { $e_string .= 'Egbk::lstat_'; $slash = 'm//'; }
7794 0         0 elsif ($string =~ /\G \b stat \b /oxgc) { $e_string .= 'Egbk::stat_'; $slash = 'm//'; }
  0         0  
7795 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7796 0         0 \b /oxgc) { $e_string .= "Egbk::filetest_(qw($1))"; $slash = 'm//'; }
  0         0  
7797             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) \b /oxgc) { $e_string .= "Egbk::${1}_"; $slash = 'm//'; }
7798 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
7799 0         0  
  0         0  
7800 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7801 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7802 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Egbk::chr_'; $slash = 'm//'; }
  0         0  
7803 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7804 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
7805 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Egbk::glob_'; $slash = 'm//'; }
  0         0  
7806 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
7807 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
7808 0         0 elsif ($string =~ /\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Egbk::opendir$1*"; $slash = 'm//'; }
  0         0  
7809             elsif ($string =~ /\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Egbk::opendir$1*"; $slash = 'm//'; }
7810             elsif ($string =~ /\G \b unlink \b /oxgc) { $e_string .= 'Egbk::unlink'; $slash = 'm//'; }
7811              
7812 0         0 # chdir
7813             elsif ($string =~ /\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
7814 0         0 $slash = 'm//';
7815              
7816 0         0 $e_string .= 'Egbk::chdir';
7817 0         0  
7818             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7819             $e_string .= $1;
7820             }
7821 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
7822             # end of chdir
7823             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return $e_string; }
7824 0         0  
  0         0  
7825             # chdir scalar value
7826             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= e_string($1); next E_STRING_LOOP; }
7827              
7828 0 0       0 # chdir qq//
  0         0  
  0         0  
7829             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7830 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq# # --> qr # #
7831 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7832 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7833 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7834 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
7835 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
7836 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
7837 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
7838             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq','{','}',$2); next E_STRING_LOOP; } # qq | | --> qr { }
7839 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq * * --> qr * *
7840             }
7841             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7842             }
7843             }
7844              
7845 0 0       0 # chdir q//
  0         0  
  0         0  
7846             elsif ($string =~ /\G \b (q) \b /oxgc) {
7847 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q# # --> qr # #
7848 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7849 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7850 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7851 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  
7852 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  
7853 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  
7854 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  
7855             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q','{','}',$2); next E_STRING_LOOP; } # q | | --> qr { }
7856 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 * *
7857             }
7858             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7859             }
7860             }
7861              
7862 0         0 # chdir ''
7863 0         0 elsif ($string =~ /\G (\') /oxgc) {
7864 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7865 0         0 while ($string !~ /\G \z/oxgc) {
7866 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7867 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; }
7868             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_chdir_q('',"'","'",$q_string); next E_STRING_LOOP; }
7869 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7870             }
7871             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7872             }
7873              
7874 0         0 # chdir ""
7875 0         0 elsif ($string =~ /\G (\") /oxgc) {
7876 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
7877 0         0 while ($string !~ /\G \z/oxgc) {
7878 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
7879 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; }
7880             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_chdir('','"','"',$qq_string); next E_STRING_LOOP; }
7881 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
7882             }
7883             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7884             }
7885             }
7886              
7887 0         0 # split
7888             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
7889 0         0 $slash = 'm//';
7890 0         0  
7891 0         0 my $e = '';
7892             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7893             $e .= $1;
7894             }
7895 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          
7896             # end of split
7897             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Egbk::split' . $e; }
7898 0         0  
  0         0  
7899             # split scalar value
7900             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Egbk::split' . $e . e_string($1); next E_STRING_LOOP; }
7901 0         0  
  0         0  
7902 0         0 # split literal space
  0         0  
7903 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Egbk::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
7904 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Egbk::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7905 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Egbk::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7906 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Egbk::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7907 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Egbk::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7908 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Egbk::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7909 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Egbk::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
7910 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Egbk::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7911 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Egbk::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7912 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Egbk::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7913 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Egbk::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7914 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Egbk::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7915             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Egbk::split' . $e . qq {' '}; next E_STRING_LOOP; }
7916             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Egbk::split' . $e . qq {" "}; next E_STRING_LOOP; }
7917              
7918 0 0       0 # split qq//
  0         0  
  0         0  
7919             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7920 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
7921 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7922 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7923 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7924 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  
7925 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  
7926 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  
7927 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  
7928             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
7929 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 * *
7930             }
7931             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7932             }
7933             }
7934              
7935 0 0       0 # split qr//
  0         0  
  0         0  
7936             elsif ($string =~ /\G \b (qr) \b /oxgc) {
7937 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
7938 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7939 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7940 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7941 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  
7942 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  
7943 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  
7944 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  
7945 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  
7946             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
7947 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 * *
7948             }
7949             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7950             }
7951             }
7952              
7953 0 0       0 # split q//
  0         0  
  0         0  
7954             elsif ($string =~ /\G \b (q) \b /oxgc) {
7955 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
7956 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7957 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7958 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7959 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  
7960 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  
7961 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  
7962 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  
7963             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
7964 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 * *
7965             }
7966             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7967             }
7968             }
7969              
7970 0 0       0 # split m//
  0         0  
  0         0  
7971             elsif ($string =~ /\G \b (m) \b /oxgc) {
7972 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 # #
7973 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7974 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7975 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7976 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  
7977 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  
7978 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  
7979 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  
7980 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  
7981             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
7982 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 * *
7983             }
7984             die __FILE__, ": Search pattern not terminated\n";
7985             }
7986             }
7987              
7988 0         0 # split ''
7989 0         0 elsif ($string =~ /\G (\') /oxgc) {
7990 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7991 0         0 while ($string !~ /\G \z/oxgc) {
7992 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7993 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
7994             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
7995 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7996             }
7997             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7998             }
7999              
8000 0         0 # split ""
8001 0         0 elsif ($string =~ /\G (\") /oxgc) {
8002 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
8003 0         0 while ($string !~ /\G \z/oxgc) {
8004 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
8005 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
8006             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
8007 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
8008             }
8009             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8010             }
8011              
8012 0         0 # split //
8013 0         0 elsif ($string =~ /\G (\/) /oxgc) {
8014 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
8015 0         0 while ($string !~ /\G \z/oxgc) {
8016 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
8017 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
8018             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
8019 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
8020             }
8021             die __FILE__, ": Search pattern not terminated\n";
8022             }
8023             }
8024              
8025 0         0 # qq//
8026 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
8027 0         0 my $ope = $1;
8028             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
8029             $e_string .= e_qq($ope,$1,$3,$2);
8030 0         0 }
8031 0         0 else {
8032 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8033 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8034 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8035 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
8036 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
8037 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
8038             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
8039 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
8040             }
8041             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8042             }
8043             }
8044              
8045 0         0 # qx//
8046 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
8047 0         0 my $ope = $1;
8048             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
8049             $e_string .= e_qq($ope,$1,$3,$2);
8050 0         0 }
8051 0         0 else {
8052 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8053 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8054 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8055 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
8056 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
8057 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
8058 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
8059             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
8060 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
8061             }
8062             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8063             }
8064             }
8065              
8066 0         0 # q//
8067 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
8068 0         0 my $ope = $1;
8069             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
8070             $e_string .= e_q($ope,$1,$3,$2);
8071 0         0 }
8072 0         0 else {
8073 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8074 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8075 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8076 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
8077 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
8078 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
8079             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
8080 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 * *
8081             }
8082             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8083             }
8084             }
8085 0         0  
8086             # ''
8087             elsif ($string =~ /\G (?
8088 44         186  
8089             # ""
8090             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8091 6         54  
8092             # ``
8093             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8094 0         0  
8095             # <<>> (a safer ARGV)
8096             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
8097 0         0  
8098             # <<= <=> <= < operator
8099             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
8100 0         0  
8101             #
8102             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
8103              
8104 0         0 # --- glob
8105             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
8106             $e_string .= 'Egbk::glob("' . $1 . '")';
8107             }
8108              
8109 0         0 # << (bit shift) --- not here document
8110 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
8111             $slash = 'm//';
8112             $e_string .= $1;
8113             }
8114              
8115 0         0 # <<~'HEREDOC'
8116 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
8117 0         0 $slash = 'm//';
8118             my $here_quote = $1;
8119             my $delimiter = $2;
8120 0 0       0  
8121 0         0 # get here document
8122 0         0 if ($here_script eq '') {
8123             $here_script = CORE::substr $_, pos $_;
8124 0 0       0 $here_script =~ s/.*?\n//oxm;
8125 0         0 }
8126 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8127 0         0 my $heredoc = $1;
8128 0         0 my $indent = $2;
8129 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8130             push @heredoc, $heredoc . qq{\n$delimiter\n};
8131             push @heredoc_delimiter, qq{\\s*$delimiter};
8132 0         0 }
8133             else {
8134 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8135             }
8136             $e_string .= qq{<<'$delimiter'};
8137             }
8138              
8139 0         0 # <<~\HEREDOC
8140 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
8141 0         0 $slash = 'm//';
8142             my $here_quote = $1;
8143             my $delimiter = $2;
8144 0 0       0  
8145 0         0 # get here document
8146 0         0 if ($here_script eq '') {
8147             $here_script = CORE::substr $_, pos $_;
8148 0 0       0 $here_script =~ s/.*?\n//oxm;
8149 0         0 }
8150 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8151 0         0 my $heredoc = $1;
8152 0         0 my $indent = $2;
8153 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8154             push @heredoc, $heredoc . qq{\n$delimiter\n};
8155             push @heredoc_delimiter, qq{\\s*$delimiter};
8156 0         0 }
8157             else {
8158 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8159             }
8160             $e_string .= qq{<<\\$delimiter};
8161             }
8162              
8163 0         0 # <<~"HEREDOC"
8164 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
8165 0         0 $slash = 'm//';
8166             my $here_quote = $1;
8167             my $delimiter = $2;
8168 0 0       0  
8169 0         0 # get here document
8170 0         0 if ($here_script eq '') {
8171             $here_script = CORE::substr $_, pos $_;
8172 0 0       0 $here_script =~ s/.*?\n//oxm;
8173 0         0 }
8174 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8175 0         0 my $heredoc = $1;
8176 0         0 my $indent = $2;
8177 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8178             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8179             push @heredoc_delimiter, qq{\\s*$delimiter};
8180 0         0 }
8181             else {
8182 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8183             }
8184             $e_string .= qq{<<"$delimiter"};
8185             }
8186              
8187 0         0 # <<~HEREDOC
8188 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
8189 0         0 $slash = 'm//';
8190             my $here_quote = $1;
8191             my $delimiter = $2;
8192 0 0       0  
8193 0         0 # get here document
8194 0         0 if ($here_script eq '') {
8195             $here_script = CORE::substr $_, pos $_;
8196 0 0       0 $here_script =~ s/.*?\n//oxm;
8197 0         0 }
8198 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8199 0         0 my $heredoc = $1;
8200 0         0 my $indent = $2;
8201 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8202             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8203             push @heredoc_delimiter, qq{\\s*$delimiter};
8204 0         0 }
8205             else {
8206 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8207             }
8208             $e_string .= qq{<<$delimiter};
8209             }
8210              
8211 0         0 # <<~`HEREDOC`
8212 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
8213 0         0 $slash = 'm//';
8214             my $here_quote = $1;
8215             my $delimiter = $2;
8216 0 0       0  
8217 0         0 # get here document
8218 0         0 if ($here_script eq '') {
8219             $here_script = CORE::substr $_, pos $_;
8220 0 0       0 $here_script =~ s/.*?\n//oxm;
8221 0         0 }
8222 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8223 0         0 my $heredoc = $1;
8224 0         0 my $indent = $2;
8225 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8226             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8227             push @heredoc_delimiter, qq{\\s*$delimiter};
8228 0         0 }
8229             else {
8230 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8231             }
8232             $e_string .= qq{<<`$delimiter`};
8233             }
8234              
8235 0         0 # <<'HEREDOC'
8236 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
8237 0         0 $slash = 'm//';
8238             my $here_quote = $1;
8239             my $delimiter = $2;
8240 0 0       0  
8241 0         0 # get here document
8242 0         0 if ($here_script eq '') {
8243             $here_script = CORE::substr $_, pos $_;
8244 0 0       0 $here_script =~ s/.*?\n//oxm;
8245 0         0 }
8246 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8247             push @heredoc, $1 . qq{\n$delimiter\n};
8248             push @heredoc_delimiter, $delimiter;
8249 0         0 }
8250             else {
8251 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8252             }
8253             $e_string .= $here_quote;
8254             }
8255              
8256 0         0 # <<\HEREDOC
8257 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
8258 0         0 $slash = 'm//';
8259             my $here_quote = $1;
8260             my $delimiter = $2;
8261 0 0       0  
8262 0         0 # get here document
8263 0         0 if ($here_script eq '') {
8264             $here_script = CORE::substr $_, pos $_;
8265 0 0       0 $here_script =~ s/.*?\n//oxm;
8266 0         0 }
8267 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8268             push @heredoc, $1 . qq{\n$delimiter\n};
8269             push @heredoc_delimiter, $delimiter;
8270 0         0 }
8271             else {
8272 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8273             }
8274             $e_string .= $here_quote;
8275             }
8276              
8277 0         0 # <<"HEREDOC"
8278 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
8279 0         0 $slash = 'm//';
8280             my $here_quote = $1;
8281             my $delimiter = $2;
8282 0 0       0  
8283 0         0 # get here document
8284 0         0 if ($here_script eq '') {
8285             $here_script = CORE::substr $_, pos $_;
8286 0 0       0 $here_script =~ s/.*?\n//oxm;
8287 0         0 }
8288 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8289             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8290             push @heredoc_delimiter, $delimiter;
8291 0         0 }
8292             else {
8293 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8294             }
8295             $e_string .= $here_quote;
8296             }
8297              
8298 0         0 # <
8299 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
8300 0         0 $slash = 'm//';
8301             my $here_quote = $1;
8302             my $delimiter = $2;
8303 0 0       0  
8304 0         0 # get here document
8305 0         0 if ($here_script eq '') {
8306             $here_script = CORE::substr $_, pos $_;
8307 0 0       0 $here_script =~ s/.*?\n//oxm;
8308 0         0 }
8309 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8310             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8311             push @heredoc_delimiter, $delimiter;
8312 0         0 }
8313             else {
8314 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8315             }
8316             $e_string .= $here_quote;
8317             }
8318              
8319 0         0 # <<`HEREDOC`
8320 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
8321 0         0 $slash = 'm//';
8322             my $here_quote = $1;
8323             my $delimiter = $2;
8324 0 0       0  
8325 0         0 # get here document
8326 0         0 if ($here_script eq '') {
8327             $here_script = CORE::substr $_, pos $_;
8328 0 0       0 $here_script =~ s/.*?\n//oxm;
8329 0         0 }
8330 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8331             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8332             push @heredoc_delimiter, $delimiter;
8333 0         0 }
8334             else {
8335 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8336             }
8337             $e_string .= $here_quote;
8338             }
8339              
8340             # any operator before div
8341             elsif ($string =~ /\G (
8342             -- | \+\+ |
8343 0         0 [\)\}\]]
  80         159  
8344              
8345             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
8346              
8347             # yada-yada or triple-dot operator
8348             elsif ($string =~ /\G (
8349 80         284 \.\.\.
  0         0  
8350              
8351             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
8352              
8353             # any operator before m//
8354             elsif ($string =~ /\G ((?>
8355              
8356             !~~ | !~ | != | ! |
8357             %= | % |
8358             &&= | && | &= | &\.= | &\. | & |
8359             -= | -> | - |
8360             :(?>\s*)= |
8361             : |
8362             <<>> |
8363             <<= | <=> | <= | < |
8364             == | => | =~ | = |
8365             >>= | >> | >= | > |
8366             \*\*= | \*\* | \*= | \* |
8367             \+= | \+ |
8368             \.\. | \.= | \. |
8369             \/\/= | \/\/ |
8370             \/= | \/ |
8371             \? |
8372             \\ |
8373             \^= | \^\.= | \^\. | \^ |
8374             \b x= |
8375             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
8376             ~~ | ~\. | ~ |
8377             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
8378             \b(?: print )\b |
8379              
8380 0         0 [,;\(\{\[]
  112         267  
8381              
8382             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
8383 112         709  
8384             # other any character
8385             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
8386              
8387 353         1554 # system error
8388             else {
8389             die __FILE__, ": Oops, this shouldn't happen!\n";
8390             }
8391 0         0 }
8392              
8393             return $e_string;
8394             }
8395              
8396             #
8397             # character class
8398 79     5434 0 335 #
8399             sub character_class {
8400 5434 100       10002 my($char,$modifier) = @_;
8401 5434 100       8189  
8402 115         253 if ($char eq '.') {
8403             if ($modifier =~ /s/) {
8404             return '${Egbk::dot_s}';
8405 23         60 }
8406             else {
8407             return '${Egbk::dot}';
8408             }
8409 92         186 }
8410             else {
8411             return Egbk::classic_character_class($char);
8412             }
8413             }
8414              
8415             #
8416             # escape capture ($1, $2, $3, ...)
8417             #
8418 5319     637 0 8788 sub e_capture {
8419 637         2668  
8420             return join '', '${Egbk::capture(', $_[0], ')}';
8421             return join '', '${', $_[0], '}';
8422             }
8423              
8424             #
8425             # escape transliteration (tr/// or y///)
8426 0     11 0 0 #
8427 11         56 sub e_tr {
8428 11   100     24 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
8429             my $e_tr = '';
8430 11         31 $modifier ||= '';
8431              
8432             $slash = 'div';
8433 11         20  
8434             # quote character class 1
8435             $charclass = q_tr($charclass);
8436 11         25  
8437             # quote character class 2
8438             $charclass2 = q_tr($charclass2);
8439 11 50       21  
8440 11 0       38 # /b /B modifier
8441 0         0 if ($modifier =~ tr/bB//d) {
8442             if ($variable eq '') {
8443             $e_tr = qq{tr$charclass$e$charclass2$modifier};
8444 0         0 }
8445             else {
8446             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
8447             }
8448 0 100       0 }
8449 11         30 else {
8450             if ($variable eq '') {
8451             $e_tr = qq{Egbk::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
8452 2         7 }
8453             else {
8454             $e_tr = qq{Egbk::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
8455             }
8456             }
8457 9         29  
8458 11         18 # clear tr/// variable
8459             $tr_variable = '';
8460 11         11 $bind_operator = '';
8461              
8462             return $e_tr;
8463             }
8464              
8465             #
8466             # quote for escape transliteration (tr/// or y///)
8467 11     22 0 64 #
8468             sub q_tr {
8469             my($charclass) = @_;
8470 22 50       95  
    0          
    0          
    0          
    0          
    0          
8471 22         58 # quote character class
8472             if ($charclass !~ /'/oxms) {
8473             return e_q('', "'", "'", $charclass); # --> q' '
8474 22         40 }
8475             elsif ($charclass !~ /\//oxms) {
8476             return e_q('q', '/', '/', $charclass); # --> q/ /
8477 0         0 }
8478             elsif ($charclass !~ /\#/oxms) {
8479             return e_q('q', '#', '#', $charclass); # --> q# #
8480 0         0 }
8481             elsif ($charclass !~ /[\<\>]/oxms) {
8482             return e_q('q', '<', '>', $charclass); # --> q< >
8483 0         0 }
8484             elsif ($charclass !~ /[\(\)]/oxms) {
8485             return e_q('q', '(', ')', $charclass); # --> q( )
8486 0         0 }
8487             elsif ($charclass !~ /[\{\}]/oxms) {
8488             return e_q('q', '{', '}', $charclass); # --> q{ }
8489 0         0 }
8490 0 0       0 else {
8491 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8492             if ($charclass !~ /\Q$char\E/xms) {
8493             return e_q('q', $char, $char, $charclass);
8494             }
8495             }
8496 0         0 }
8497              
8498             return e_q('q', '{', '}', $charclass);
8499             }
8500              
8501             #
8502             # escape q string (q//, '')
8503 0     3967 0 0 #
8504             sub e_q {
8505 3967         9809 my($ope,$delimiter,$end_delimiter,$string) = @_;
8506              
8507 3967         5673 $slash = 'div';
8508 3967         25134  
8509             my @char = $string =~ / \G (?>$q_char) /oxmsg;
8510             for (my $i=0; $i <= $#char; $i++) {
8511 3967 100 100     10541  
    100 100        
8512 21145         118383 # escape last octet of multiple-octet
8513             if ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
8514             $char[$i] = $1 . '\\' . $2;
8515 1         154 }
8516             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8517             $char[$i] = $1 . '\\' . $2;
8518 22 100 100     90 }
8519 3967         15733 }
8520             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8521             $char[-1] = $1 . '\\' . $2;
8522 204         641 }
8523 3967         21252  
8524             return join '', $ope, $delimiter, @char, $end_delimiter;
8525             return join '', $ope, $delimiter, $string, $end_delimiter;
8526             }
8527              
8528             #
8529             # escape qq string (qq//, "", qx//, ``)
8530 0     9552 0 0 #
8531             sub e_qq {
8532 9552         21183 my($ope,$delimiter,$end_delimiter,$string) = @_;
8533              
8534 9552         13159 $slash = 'div';
8535 9552         11296  
8536             my $left_e = 0;
8537             my $right_e = 0;
8538 9552         10950  
8539             # split regexp
8540             my @char = $string =~ /\G((?>
8541             [^\x81-\xFE\\\$]|[\x81-\xFE][\x00-\xFF] |
8542             \\x\{ (?>[0-9A-Fa-f]+) \} |
8543             \\o\{ (?>[0-7]+) \} |
8544             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8545             \\ $q_char |
8546             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8547             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8548             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8549             \$ (?>\s* [0-9]+) |
8550             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8551             \$ \$ (?![\w\{]) |
8552             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8553             $q_char
8554 9552         350903 ))/oxmsg;
8555              
8556             for (my $i=0; $i <= $#char; $i++) {
8557 9552 50 66     28914  
    50 33        
    100          
    100          
    50          
8558 307164         967138 # "\L\u" --> "\u\L"
8559             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8560             @char[$i,$i+1] = @char[$i+1,$i];
8561             }
8562              
8563 0         0 # "\U\l" --> "\l\U"
8564             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8565             @char[$i,$i+1] = @char[$i+1,$i];
8566             }
8567              
8568 0         0 # octal escape sequence
8569             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8570             $char[$i] = Egbk::octchr($1);
8571             }
8572              
8573 1         5 # hexadecimal escape sequence
8574             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8575             $char[$i] = Egbk::hexchr($1);
8576             }
8577              
8578 1         4 # \N{CHARNAME} --> N{CHARNAME}
8579             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8580             $char[$i] = $1;
8581 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          
8582              
8583             if (0) {
8584             }
8585              
8586             # escape last octet of multiple-octet
8587 307164         2805518 # my $metachar = qr/[\@\\\|]/oxms; # '|' is for qx//, ``, open(), and system()
8588 0         0 # variable $delimiter and $end_delimiter can be ''
8589             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\@\\\|$delimiter$end_delimiter]) \z/xms) {
8590             $char[$i] = $1 . '\\' . $2;
8591             }
8592              
8593             # \F
8594             #
8595             # P.69 Table 2-6. Translation escapes
8596             # in Chapter 2: Bits and Pieces
8597             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8598             # (and so on)
8599              
8600 1342 50       4478 # \u \l \U \L \F \Q \E
8601 647         1594 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8602             if ($right_e < $left_e) {
8603             $char[$i] = '\\' . $char[$i];
8604             }
8605             }
8606             elsif ($char[$i] eq '\u') {
8607              
8608             # "STRING @{[ LIST EXPR ]} MORE STRING"
8609              
8610             # P.257 Other Tricks You Can Do with Hard References
8611             # in Chapter 8: References
8612             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
8613              
8614             # P.353 Other Tricks You Can Do with Hard References
8615             # in Chapter 8: References
8616             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8617              
8618 0         0 # (and so on)
8619 0         0  
8620             $char[$i] = '@{[Egbk::ucfirst qq<';
8621             $left_e++;
8622 0         0 }
8623 0         0 elsif ($char[$i] eq '\l') {
8624             $char[$i] = '@{[Egbk::lcfirst qq<';
8625             $left_e++;
8626 0         0 }
8627 0         0 elsif ($char[$i] eq '\U') {
8628             $char[$i] = '@{[Egbk::uc qq<';
8629             $left_e++;
8630 0         0 }
8631 6         10 elsif ($char[$i] eq '\L') {
8632             $char[$i] = '@{[Egbk::lc qq<';
8633             $left_e++;
8634 6         9 }
8635 9         21 elsif ($char[$i] eq '\F') {
8636             $char[$i] = '@{[Egbk::fc qq<';
8637             $left_e++;
8638 9         21 }
8639 0         0 elsif ($char[$i] eq '\Q') {
8640             $char[$i] = '@{[CORE::quotemeta qq<';
8641             $left_e++;
8642 0 50       0 }
8643 12         27 elsif ($char[$i] eq '\E') {
8644 12         16 if ($right_e < $left_e) {
8645             $char[$i] = '>]}';
8646             $right_e++;
8647 12         23 }
8648             else {
8649             $char[$i] = '';
8650             }
8651 0         0 }
8652 0 0       0 elsif ($char[$i] eq '\Q') {
8653 0         0 while (1) {
8654             if (++$i > $#char) {
8655 0 0       0 last;
8656 0         0 }
8657             if ($char[$i] eq '\E') {
8658             last;
8659             }
8660             }
8661             }
8662             elsif ($char[$i] eq '\E') {
8663             }
8664              
8665             # $0 --> $0
8666             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8667             }
8668             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8669             }
8670              
8671             # $$ --> $$
8672             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8673             }
8674              
8675             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8676 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8677             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8678             $char[$i] = e_capture($1);
8679 415         1011 }
8680             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8681             $char[$i] = e_capture($1);
8682             }
8683              
8684 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8685             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8686             $char[$i] = e_capture($1.'->'.$2);
8687             }
8688              
8689 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8690             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8691             $char[$i] = e_capture($1.'->'.$2);
8692             }
8693              
8694 0         0 # $$foo
8695             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8696             $char[$i] = e_capture($1);
8697             }
8698              
8699 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egbk::PREMATCH()
8700             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8701             $char[$i] = '@{[Egbk::PREMATCH()]}';
8702             }
8703              
8704 44         135 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egbk::MATCH()
8705             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8706             $char[$i] = '@{[Egbk::MATCH()]}';
8707             }
8708              
8709 45         139 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egbk::POSTMATCH()
8710             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8711             $char[$i] = '@{[Egbk::POSTMATCH()]}';
8712             }
8713              
8714             # ${ foo } --> ${ foo }
8715             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8716             }
8717              
8718 33         103 # ${ ... }
8719             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8720             $char[$i] = e_capture($1);
8721             }
8722             }
8723 0 100       0  
8724 9552         19142 # return string
8725             if ($left_e > $right_e) {
8726 3         20 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
8727             }
8728             return join '', $ope, $delimiter, @char, $end_delimiter;
8729             }
8730              
8731             #
8732             # escape qw string (qw//)
8733 9549     34 0 76033 #
8734             sub e_qw {
8735 34         145 my($ope,$delimiter,$end_delimiter,$string) = @_;
8736              
8737             $slash = 'div';
8738 34         77  
  34         296  
8739 621 50       942 # choice again delimiter
    0          
    0          
    0          
    0          
8740 34         161 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
8741             if (not $octet{$end_delimiter}) {
8742             return join '', $ope, $delimiter, $string, $end_delimiter;
8743 34         216 }
8744             elsif (not $octet{')'}) {
8745             return join '', $ope, '(', $string, ')';
8746 0         0 }
8747             elsif (not $octet{'}'}) {
8748             return join '', $ope, '{', $string, '}';
8749 0         0 }
8750             elsif (not $octet{']'}) {
8751             return join '', $ope, '[', $string, ']';
8752 0         0 }
8753             elsif (not $octet{'>'}) {
8754             return join '', $ope, '<', $string, '>';
8755 0         0 }
8756 0 0       0 else {
8757 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8758             if (not $octet{$char}) {
8759             return join '', $ope, $char, $string, $char;
8760             }
8761             }
8762             }
8763 0         0  
8764 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
8765 0         0 my @string = CORE::split(/\s+/, $string);
8766 0         0 for my $string (@string) {
8767 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
8768 0         0 for my $octet (@octet) {
8769             if ($octet =~ /\A (['\\]) \z/oxms) {
8770             $octet = '\\' . $1;
8771 0         0 }
8772             }
8773 0         0 $string = join '', @octet;
  0         0  
8774             }
8775             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
8776             }
8777              
8778             #
8779             # escape here document (<<"HEREDOC", <
8780 0     108 0 0 #
8781             sub e_heredoc {
8782 108         283 my($string) = @_;
8783              
8784 108         171 $slash = 'm//';
8785              
8786 108         346 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
8787 108         154  
8788             my $left_e = 0;
8789             my $right_e = 0;
8790 108         138  
8791             # split regexp
8792             my @char = $string =~ /\G((?>
8793             [^\x81-\xFE\\\$]|[\x81-\xFE][\x00-\xFF] |
8794             \\x\{ (?>[0-9A-Fa-f]+) \} |
8795             \\o\{ (?>[0-7]+) \} |
8796             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8797             \\ $q_char |
8798             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8799             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8800             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8801             \$ (?>\s* [0-9]+) |
8802             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8803             \$ \$ (?![\w\{]) |
8804             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8805             $q_char
8806 108         10319 ))/oxmsg;
8807              
8808             for (my $i=0; $i <= $#char; $i++) {
8809 108 50 66     504  
    50 33        
    100          
    100          
    50          
8810 3199         9612 # "\L\u" --> "\u\L"
8811             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8812             @char[$i,$i+1] = @char[$i+1,$i];
8813             }
8814              
8815 0         0 # "\U\l" --> "\l\U"
8816             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8817             @char[$i,$i+1] = @char[$i+1,$i];
8818             }
8819              
8820 0         0 # octal escape sequence
8821             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8822             $char[$i] = Egbk::octchr($1);
8823             }
8824              
8825 1         3 # hexadecimal escape sequence
8826             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8827             $char[$i] = Egbk::hexchr($1);
8828             }
8829              
8830 1         4 # \N{CHARNAME} --> N{CHARNAME}
8831             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8832             $char[$i] = $1;
8833 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          
8834              
8835             if (0) {
8836             }
8837 3199         26720  
8838 0         0 # escape character
8839             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
8840             $char[$i] = $1 . '\\' . $2;
8841             }
8842              
8843 57 50       213 # \u \l \U \L \F \Q \E
8844 72         135 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8845             if ($right_e < $left_e) {
8846             $char[$i] = '\\' . $char[$i];
8847             }
8848 0         0 }
8849 0         0 elsif ($char[$i] eq '\u') {
8850             $char[$i] = '@{[Egbk::ucfirst qq<';
8851             $left_e++;
8852 0         0 }
8853 0         0 elsif ($char[$i] eq '\l') {
8854             $char[$i] = '@{[Egbk::lcfirst qq<';
8855             $left_e++;
8856 0         0 }
8857 0         0 elsif ($char[$i] eq '\U') {
8858             $char[$i] = '@{[Egbk::uc qq<';
8859             $left_e++;
8860 0         0 }
8861 6         9 elsif ($char[$i] eq '\L') {
8862             $char[$i] = '@{[Egbk::lc qq<';
8863             $left_e++;
8864 6         11 }
8865 0         0 elsif ($char[$i] eq '\F') {
8866             $char[$i] = '@{[Egbk::fc qq<';
8867             $left_e++;
8868 0         0 }
8869 0         0 elsif ($char[$i] eq '\Q') {
8870             $char[$i] = '@{[CORE::quotemeta qq<';
8871             $left_e++;
8872 0 50       0 }
8873 3         6 elsif ($char[$i] eq '\E') {
8874 3         4 if ($right_e < $left_e) {
8875             $char[$i] = '>]}';
8876             $right_e++;
8877 3         7 }
8878             else {
8879             $char[$i] = '';
8880             }
8881 0         0 }
8882 0 0       0 elsif ($char[$i] eq '\Q') {
8883 0         0 while (1) {
8884             if (++$i > $#char) {
8885 0 0       0 last;
8886 0         0 }
8887             if ($char[$i] eq '\E') {
8888             last;
8889             }
8890             }
8891             }
8892             elsif ($char[$i] eq '\E') {
8893             }
8894              
8895             # $0 --> $0
8896             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8897             }
8898             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8899             }
8900              
8901             # $$ --> $$
8902             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8903             }
8904              
8905             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8906 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8907             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8908             $char[$i] = e_capture($1);
8909 0         0 }
8910             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8911             $char[$i] = e_capture($1);
8912             }
8913              
8914 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8915             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8916             $char[$i] = e_capture($1.'->'.$2);
8917             }
8918              
8919 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8920             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8921             $char[$i] = e_capture($1.'->'.$2);
8922             }
8923              
8924 0         0 # $$foo
8925             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8926             $char[$i] = e_capture($1);
8927             }
8928              
8929 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egbk::PREMATCH()
8930             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8931             $char[$i] = '@{[Egbk::PREMATCH()]}';
8932             }
8933              
8934 8         52 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egbk::MATCH()
8935             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8936             $char[$i] = '@{[Egbk::MATCH()]}';
8937             }
8938              
8939 8         48 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egbk::POSTMATCH()
8940             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8941             $char[$i] = '@{[Egbk::POSTMATCH()]}';
8942             }
8943              
8944             # ${ foo } --> ${ foo }
8945             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8946             }
8947              
8948 6         37 # ${ ... }
8949             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8950             $char[$i] = e_capture($1);
8951             }
8952             }
8953 0 100       0  
8954 108         255 # return string
8955             if ($left_e > $right_e) {
8956 3         25 return join '', @char, '>]}' x ($left_e - $right_e);
8957             }
8958             return join '', @char;
8959             }
8960              
8961             #
8962             # escape regexp (m//, qr//)
8963 105     1835 0 755 #
8964 1835   100     7452 sub e_qr {
8965             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
8966 1835         6423 $modifier ||= '';
8967 1835 50       3161  
8968 1835         4438 $modifier =~ tr/p//d;
8969 0         0 if ($modifier =~ /([adlu])/oxms) {
8970 0 0       0 my $line = 0;
8971 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
8972 0         0 if ($filename ne __FILE__) {
8973             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
8974             last;
8975 0         0 }
8976             }
8977             die qq{Unsupported modifier "$1" used at line $line.\n};
8978 0         0 }
8979              
8980             $slash = 'div';
8981 1835 100       2934  
    100          
8982 1835         5054 # literal null string pattern
8983 8         9 if ($string eq '') {
8984 8         9 $modifier =~ tr/bB//d;
8985             $modifier =~ tr/i//d;
8986             return join '', $ope, $delimiter, $end_delimiter, $modifier;
8987             }
8988              
8989             # /b /B modifier
8990             elsif ($modifier =~ tr/bB//d) {
8991 8 50       38  
8992 240         518 # choice again delimiter
8993 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
8994 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
8995 0         0 my %octet = map {$_ => 1} @char;
8996 0         0 if (not $octet{')'}) {
8997             $delimiter = '(';
8998             $end_delimiter = ')';
8999 0         0 }
9000 0         0 elsif (not $octet{'}'}) {
9001             $delimiter = '{';
9002             $end_delimiter = '}';
9003 0         0 }
9004 0         0 elsif (not $octet{']'}) {
9005             $delimiter = '[';
9006             $end_delimiter = ']';
9007 0         0 }
9008 0         0 elsif (not $octet{'>'}) {
9009             $delimiter = '<';
9010             $end_delimiter = '>';
9011 0         0 }
9012 0 0       0 else {
9013 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9014 0         0 if (not $octet{$char}) {
9015 0         0 $delimiter = $char;
9016             $end_delimiter = $char;
9017             last;
9018             }
9019             }
9020             }
9021 0 100 100     0 }
9022 240         1047  
9023             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9024             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
9025 90         500 }
9026             else {
9027             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9028             }
9029 150 100       830 }
9030 1587         3819  
9031             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9032             my $metachar = qr/[\@\\|[\]{^]/oxms;
9033 1587         5338  
9034             # split regexp
9035             my @char = $string =~ /\G((?>
9036             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
9037             \\x (?>[0-9A-Fa-f]{1,2}) |
9038             \\ (?>[0-7]{2,3}) |
9039             \\c [\x40-\x5F] |
9040             \\x\{ (?>[0-9A-Fa-f]+) \} |
9041             \\o\{ (?>[0-7]+) \} |
9042             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9043             \\ $q_char |
9044             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9045             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9046             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9047             [\$\@] $qq_variable |
9048             \$ (?>\s* [0-9]+) |
9049             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9050             \$ \$ (?![\w\{]) |
9051             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9052             \[\^ |
9053             \[\: (?>[a-z]+) :\] |
9054             \[\:\^ (?>[a-z]+) :\] |
9055             \(\? |
9056             $q_char
9057             ))/oxmsg;
9058 1587 50       132822  
9059 1587         6846 # choice again delimiter
  0         0  
9060 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9061 0         0 my %octet = map {$_ => 1} @char;
9062 0         0 if (not $octet{')'}) {
9063             $delimiter = '(';
9064             $end_delimiter = ')';
9065 0         0 }
9066 0         0 elsif (not $octet{'}'}) {
9067             $delimiter = '{';
9068             $end_delimiter = '}';
9069 0         0 }
9070 0         0 elsif (not $octet{']'}) {
9071             $delimiter = '[';
9072             $end_delimiter = ']';
9073 0         0 }
9074 0         0 elsif (not $octet{'>'}) {
9075             $delimiter = '<';
9076             $end_delimiter = '>';
9077 0         0 }
9078 0 0       0 else {
9079 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9080 0         0 if (not $octet{$char}) {
9081 0         0 $delimiter = $char;
9082             $end_delimiter = $char;
9083             last;
9084             }
9085             }
9086             }
9087 0         0 }
9088 1587         2311  
9089 1587         2007 my $left_e = 0;
9090             my $right_e = 0;
9091             for (my $i=0; $i <= $#char; $i++) {
9092 1587 50 66     3979  
    50 66        
    100          
    100          
    100          
    100          
9093 5514         26414 # "\L\u" --> "\u\L"
9094             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9095             @char[$i,$i+1] = @char[$i+1,$i];
9096             }
9097              
9098 0         0 # "\U\l" --> "\l\U"
9099             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9100             @char[$i,$i+1] = @char[$i+1,$i];
9101             }
9102              
9103 0         0 # octal escape sequence
9104             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9105             $char[$i] = Egbk::octchr($1);
9106             }
9107              
9108 1         3 # hexadecimal escape sequence
9109             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9110             $char[$i] = Egbk::hexchr($1);
9111             }
9112              
9113             # \b{...} --> b\{...}
9114             # \B{...} --> B\{...}
9115             # \N{CHARNAME} --> N\{CHARNAME}
9116             # \p{PROPERTY} --> p\{PROPERTY}
9117 1         3 # \P{PROPERTY} --> P\{PROPERTY}
9118             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9119             $char[$i] = $1 . '\\' . $2;
9120             }
9121              
9122 6         21 # \p, \P, \X --> p, P, X
9123             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9124             $char[$i] = $1;
9125 4 100 100     11 }
    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          
9126              
9127             if (0) {
9128             }
9129 5514         35723  
9130 0         0 # escape last octet of multiple-octet
9131             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9132             $char[$i] = $1 . '\\' . $2;
9133             }
9134              
9135 77 50 33     315 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
9136 6         164 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9137             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)) {
9138             $char[$i] .= join '', splice @char, $i+1, 3;
9139 0         0 }
9140             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)) {
9141             $char[$i] .= join '', splice @char, $i+1, 2;
9142 0         0 }
9143             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)) {
9144             $char[$i] .= join '', splice @char, $i+1, 1;
9145             }
9146             }
9147              
9148 0         0 # open character class [...]
9149             elsif ($char[$i] eq '[') {
9150             my $left = $i;
9151              
9152             # [] make die "Unmatched [] in regexp ...\n"
9153 586 100       922 # (and so on)
9154 586         1412  
9155             if ($char[$i+1] eq ']') {
9156             $i++;
9157 3         5 }
9158 586 50       734  
9159 2583         3631 while (1) {
9160             if (++$i > $#char) {
9161 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9162 2583         3805 }
9163             if ($char[$i] eq ']') {
9164             my $right = $i;
9165 586 100       681  
9166 586         3042 # [...]
  90         213  
9167             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9168             splice @char, $left, $right-$left+1, sprintf(q{@{[Egbk::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9169 270         441 }
9170             else {
9171             splice @char, $left, $right-$left+1, Egbk::charlist_qr(@char[$left+1..$right-1], $modifier);
9172 496         1788 }
9173 586         1024  
9174             $i = $left;
9175             last;
9176             }
9177             }
9178             }
9179              
9180 586         1656 # open character class [^...]
9181             elsif ($char[$i] eq '[^') {
9182             my $left = $i;
9183              
9184             # [^] make die "Unmatched [] in regexp ...\n"
9185 328 100       486 # (and so on)
9186 328         711  
9187             if ($char[$i+1] eq ']') {
9188             $i++;
9189 5         8 }
9190 328 50       372  
9191 1447         1962 while (1) {
9192             if (++$i > $#char) {
9193 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9194 1447         2061 }
9195             if ($char[$i] eq ']') {
9196             my $right = $i;
9197 328 100       356  
9198 328         1629 # [^...]
  90         220  
9199             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9200             splice @char, $left, $right-$left+1, sprintf(q{@{[Egbk::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9201 270         440 }
9202             else {
9203             splice @char, $left, $right-$left+1, Egbk::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9204 238         775 }
9205 328         609  
9206             $i = $left;
9207             last;
9208             }
9209             }
9210             }
9211              
9212 328         892 # rewrite character class or escape character
9213             elsif (my $char = character_class($char[$i],$modifier)) {
9214             $char[$i] = $char;
9215             }
9216              
9217 215 50       600 # /i modifier
9218 238         443 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egbk::uc($char[$i]) ne Egbk::fc($char[$i]))) {
9219             if (CORE::length(Egbk::fc($char[$i])) == 1) {
9220             $char[$i] = '[' . Egbk::uc($char[$i]) . Egbk::fc($char[$i]) . ']';
9221 238         429 }
9222             else {
9223             $char[$i] = '(?:' . Egbk::uc($char[$i]) . '|' . Egbk::fc($char[$i]) . ')';
9224             }
9225             }
9226              
9227 0 50       0 # \u \l \U \L \F \Q \E
9228 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9229             if ($right_e < $left_e) {
9230             $char[$i] = '\\' . $char[$i];
9231             }
9232 0         0 }
9233 0         0 elsif ($char[$i] eq '\u') {
9234             $char[$i] = '@{[Egbk::ucfirst qq<';
9235             $left_e++;
9236 0         0 }
9237 0         0 elsif ($char[$i] eq '\l') {
9238             $char[$i] = '@{[Egbk::lcfirst qq<';
9239             $left_e++;
9240 0         0 }
9241 1         3 elsif ($char[$i] eq '\U') {
9242             $char[$i] = '@{[Egbk::uc qq<';
9243             $left_e++;
9244 1         3 }
9245 1         2 elsif ($char[$i] eq '\L') {
9246             $char[$i] = '@{[Egbk::lc qq<';
9247             $left_e++;
9248 1         3 }
9249 9         18 elsif ($char[$i] eq '\F') {
9250             $char[$i] = '@{[Egbk::fc qq<';
9251             $left_e++;
9252 9         20 }
9253 22         48 elsif ($char[$i] eq '\Q') {
9254             $char[$i] = '@{[CORE::quotemeta qq<';
9255             $left_e++;
9256 22 50       72 }
9257 33         80 elsif ($char[$i] eq '\E') {
9258 33         50 if ($right_e < $left_e) {
9259             $char[$i] = '>]}';
9260             $right_e++;
9261 33         76 }
9262             else {
9263             $char[$i] = '';
9264             }
9265 0         0 }
9266 0 0       0 elsif ($char[$i] eq '\Q') {
9267 0         0 while (1) {
9268             if (++$i > $#char) {
9269 0 0       0 last;
9270 0         0 }
9271             if ($char[$i] eq '\E') {
9272             last;
9273             }
9274             }
9275             }
9276             elsif ($char[$i] eq '\E') {
9277             }
9278              
9279 0 0       0 # $0 --> $0
9280 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9281             if ($ignorecase) {
9282             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9283             }
9284 0 0       0 }
9285 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9286             if ($ignorecase) {
9287             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9288             }
9289             }
9290              
9291             # $$ --> $$
9292             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9293             }
9294              
9295             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9296 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9297 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9298 0         0 $char[$i] = e_capture($1);
9299             if ($ignorecase) {
9300             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9301             }
9302 0         0 }
9303 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9304 0         0 $char[$i] = e_capture($1);
9305             if ($ignorecase) {
9306             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9307             }
9308             }
9309              
9310 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
9311 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) {
9312 0         0 $char[$i] = e_capture($1.'->'.$2);
9313             if ($ignorecase) {
9314             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9315             }
9316             }
9317              
9318 0         0 # $$foo{ ... } --> $ $foo->{ ... }
9319 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) {
9320 0         0 $char[$i] = e_capture($1.'->'.$2);
9321             if ($ignorecase) {
9322             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9323             }
9324             }
9325              
9326 0         0 # $$foo
9327 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
9328 0         0 $char[$i] = e_capture($1);
9329             if ($ignorecase) {
9330             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9331             }
9332             }
9333              
9334 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egbk::PREMATCH()
9335 8         21 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
9336             if ($ignorecase) {
9337             $char[$i] = '@{[Egbk::ignorecase(Egbk::PREMATCH())]}';
9338 0         0 }
9339             else {
9340             $char[$i] = '@{[Egbk::PREMATCH()]}';
9341             }
9342             }
9343              
9344 8 50       23 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egbk::MATCH()
9345 8         23 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
9346             if ($ignorecase) {
9347             $char[$i] = '@{[Egbk::ignorecase(Egbk::MATCH())]}';
9348 0         0 }
9349             else {
9350             $char[$i] = '@{[Egbk::MATCH()]}';
9351             }
9352             }
9353              
9354 8 50       25 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egbk::POSTMATCH()
9355 6         19 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
9356             if ($ignorecase) {
9357             $char[$i] = '@{[Egbk::ignorecase(Egbk::POSTMATCH())]}';
9358 0         0 }
9359             else {
9360             $char[$i] = '@{[Egbk::POSTMATCH()]}';
9361             }
9362             }
9363              
9364 6 0       22 # ${ foo }
9365 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) {
9366             if ($ignorecase) {
9367             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9368             }
9369             }
9370              
9371 0         0 # ${ ... }
9372 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
9373 0         0 $char[$i] = e_capture($1);
9374             if ($ignorecase) {
9375             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9376             }
9377             }
9378              
9379 0         0 # $scalar or @array
9380 31 100       137 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
9381 31         107 $char[$i] = e_string($char[$i]);
9382             if ($ignorecase) {
9383             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9384             }
9385             }
9386              
9387 4 100 66     14 # quote character before ? + * {
    50          
9388             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9389             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
9390 188         1395 }
9391 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9392 0         0 my $char = $char[$i-1];
9393             if ($char[$i] eq '{') {
9394             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
9395 0         0 }
9396             else {
9397             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
9398             }
9399 0         0 }
9400             else {
9401             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9402             }
9403             }
9404             }
9405 187         774  
9406 1587 50       2907 # make regexp string
9407 1587 0 0     3253 $modifier =~ tr/i//d;
9408 0         0 if ($left_e > $right_e) {
9409             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9410             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
9411 0         0 }
9412             else {
9413             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
9414 0 100 100     0 }
9415 1587         7854 }
9416             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9417             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
9418 94         676 }
9419             else {
9420             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9421             }
9422             }
9423              
9424             #
9425             # double quote stuff
9426 1493     540 0 12702 #
9427             sub qq_stuff {
9428             my($delimiter,$end_delimiter,$stuff) = @_;
9429 540 100       997  
9430 540         1282 # scalar variable or array variable
9431             if ($stuff =~ /\A [\$\@] /oxms) {
9432             return $stuff;
9433             }
9434 300         1147  
  240         725  
9435 280         759 # quote by delimiter
9436 240 50       610 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
9437 240 50       428 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9438 240 50       359 next if $char eq $delimiter;
9439 240         436 next if $char eq $end_delimiter;
9440             if (not $octet{$char}) {
9441             return join '', 'qq', $char, $stuff, $char;
9442 240         954 }
9443             }
9444             return join '', 'qq', '<', $stuff, '>';
9445             }
9446              
9447             #
9448             # escape regexp (m'', qr'', and m''b, qr''b)
9449 0     163 0 0 #
9450 163   100     665 sub e_qr_q {
9451             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9452 163         457 $modifier ||= '';
9453 163 50       267  
9454 163         405 $modifier =~ tr/p//d;
9455 0         0 if ($modifier =~ /([adlu])/oxms) {
9456 0 0       0 my $line = 0;
9457 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9458 0         0 if ($filename ne __FILE__) {
9459             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9460             last;
9461 0         0 }
9462             }
9463             die qq{Unsupported modifier "$1" used at line $line.\n};
9464 0         0 }
9465              
9466             $slash = 'div';
9467 163 100       229  
    100          
9468 163         374 # literal null string pattern
9469 8         12 if ($string eq '') {
9470 8         8 $modifier =~ tr/bB//d;
9471             $modifier =~ tr/i//d;
9472             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9473             }
9474              
9475 8         39 # with /b /B modifier
9476             elsif ($modifier =~ tr/bB//d) {
9477             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
9478             }
9479              
9480 89         210 # without /b /B modifier
9481             else {
9482             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
9483             }
9484             }
9485              
9486             #
9487             # escape regexp (m'', qr'')
9488 66     66 0 138 #
9489             sub e_qr_qt {
9490 66 100       150 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9491              
9492             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9493 66         174  
9494             # split regexp
9495             my @char = $string =~ /\G((?>
9496             [^\x81-\xFE\\\[\$\@\/] |
9497             [\x81-\xFE][\x00-\xFF] |
9498             \[\^ |
9499             \[\: (?>[a-z]+) \:\] |
9500             \[\:\^ (?>[a-z]+) \:\] |
9501             [\$\@\/] |
9502             \\ (?:$q_char) |
9503             (?:$q_char)
9504             ))/oxmsg;
9505 66         651  
9506 66 100 100     201 # unescape character
    50 100        
    50 66        
    50          
    50          
    100          
    50          
9507             for (my $i=0; $i <= $#char; $i++) {
9508             if (0) {
9509             }
9510 79         779  
9511 0         0 # escape last octet of multiple-octet
9512             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9513             $char[$i] = $1 . '\\' . $2;
9514             }
9515              
9516 2         15 # open character class [...]
9517 0 0       0 elsif ($char[$i] eq '[') {
9518 0         0 my $left = $i;
9519             if ($char[$i+1] eq ']') {
9520 0         0 $i++;
9521 0 0       0 }
9522 0         0 while (1) {
9523             if (++$i > $#char) {
9524 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9525 0         0 }
9526             if ($char[$i] eq ']') {
9527             my $right = $i;
9528 0         0  
9529             # [...]
9530 0         0 splice @char, $left, $right-$left+1, Egbk::charlist_qr(@char[$left+1..$right-1], $modifier);
9531 0         0  
9532             $i = $left;
9533             last;
9534             }
9535             }
9536             }
9537              
9538 0         0 # open character class [^...]
9539 0 0       0 elsif ($char[$i] eq '[^') {
9540 0         0 my $left = $i;
9541             if ($char[$i+1] eq ']') {
9542 0         0 $i++;
9543 0 0       0 }
9544 0         0 while (1) {
9545             if (++$i > $#char) {
9546 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9547 0         0 }
9548             if ($char[$i] eq ']') {
9549             my $right = $i;
9550 0         0  
9551             # [^...]
9552 0         0 splice @char, $left, $right-$left+1, Egbk::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9553 0         0  
9554             $i = $left;
9555             last;
9556             }
9557             }
9558             }
9559              
9560 0         0 # escape $ @ / and \
9561             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9562             $char[$i] = '\\' . $char[$i];
9563             }
9564              
9565 0         0 # rewrite character class or escape character
9566             elsif (my $char = character_class($char[$i],$modifier)) {
9567             $char[$i] = $char;
9568             }
9569              
9570 0 50       0 # /i modifier
9571 16         38 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egbk::uc($char[$i]) ne Egbk::fc($char[$i]))) {
9572             if (CORE::length(Egbk::fc($char[$i])) == 1) {
9573             $char[$i] = '[' . Egbk::uc($char[$i]) . Egbk::fc($char[$i]) . ']';
9574 16         45 }
9575             else {
9576             $char[$i] = '(?:' . Egbk::uc($char[$i]) . '|' . Egbk::fc($char[$i]) . ')';
9577             }
9578             }
9579              
9580 0 0       0 # quote character before ? + * {
9581             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9582             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
9583 0         0 }
9584             else {
9585             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9586             }
9587             }
9588 0         0 }
9589 66         110  
9590             $delimiter = '/';
9591 66         79 $end_delimiter = '/';
9592 66         93  
9593             $modifier =~ tr/i//d;
9594             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9595             }
9596              
9597             #
9598             # escape regexp (m''b, qr''b)
9599 66     89 0 395 #
9600             sub e_qr_qb {
9601             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9602 89         185  
9603             # split regexp
9604             my @char = $string =~ /\G ((?>[^\\]|\\\\|[\x00-\xFF])) /oxmsg;
9605 89         341  
9606 89 50       227 # unescape character
    50          
9607             for (my $i=0; $i <= $#char; $i++) {
9608             if (0) {
9609             }
9610 199         579  
9611             # remain \\
9612             elsif ($char[$i] eq '\\\\') {
9613             }
9614              
9615 0         0 # escape $ @ / and \
9616             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9617             $char[$i] = '\\' . $char[$i];
9618             }
9619 0         0 }
9620 89         118  
9621 89         108 $delimiter = '/';
9622             $end_delimiter = '/';
9623             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9624             }
9625              
9626             #
9627             # escape regexp (s/here//)
9628 89     194 0 484 #
9629 194   100     526 sub e_s1 {
9630             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9631 194         789 $modifier ||= '';
9632 194 50       285  
9633 194         654 $modifier =~ tr/p//d;
9634 0         0 if ($modifier =~ /([adlu])/oxms) {
9635 0 0       0 my $line = 0;
9636 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9637 0         0 if ($filename ne __FILE__) {
9638             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9639             last;
9640 0         0 }
9641             }
9642             die qq{Unsupported modifier "$1" used at line $line.\n};
9643 0         0 }
9644              
9645             $slash = 'div';
9646 194 100       355  
    100          
9647 194         676 # literal null string pattern
9648 8         16 if ($string eq '') {
9649 8         10 $modifier =~ tr/bB//d;
9650             $modifier =~ tr/i//d;
9651             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9652             }
9653              
9654             # /b /B modifier
9655             elsif ($modifier =~ tr/bB//d) {
9656 8 50       51  
9657 44         73 # choice again delimiter
9658 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
9659 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
9660 0         0 my %octet = map {$_ => 1} @char;
9661 0         0 if (not $octet{')'}) {
9662             $delimiter = '(';
9663             $end_delimiter = ')';
9664 0         0 }
9665 0         0 elsif (not $octet{'}'}) {
9666             $delimiter = '{';
9667             $end_delimiter = '}';
9668 0         0 }
9669 0         0 elsif (not $octet{']'}) {
9670             $delimiter = '[';
9671             $end_delimiter = ']';
9672 0         0 }
9673 0         0 elsif (not $octet{'>'}) {
9674             $delimiter = '<';
9675             $end_delimiter = '>';
9676 0         0 }
9677 0 0       0 else {
9678 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9679 0         0 if (not $octet{$char}) {
9680 0         0 $delimiter = $char;
9681             $end_delimiter = $char;
9682             last;
9683             }
9684             }
9685             }
9686 0         0 }
9687 44         58  
9688 44         45 my $prematch = '';
9689             $prematch = q{(\G[\x00-\xFF]*?)};
9690             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9691 44 100       254 }
9692 142         434  
9693             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9694             my $metachar = qr/[\@\\|[\]{^]/oxms;
9695 142         527  
9696             # split regexp
9697             my @char = $string =~ /\G((?>
9698             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
9699             \\ (?>[1-9][0-9]*) |
9700             \\g (?>\s*) (?>[1-9][0-9]*) |
9701             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9702             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9703             \\x (?>[0-9A-Fa-f]{1,2}) |
9704             \\ (?>[0-7]{2,3}) |
9705             \\c [\x40-\x5F] |
9706             \\x\{ (?>[0-9A-Fa-f]+) \} |
9707             \\o\{ (?>[0-7]+) \} |
9708             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9709             \\ $q_char |
9710             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9711             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9712             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9713             [\$\@] $qq_variable |
9714             \$ (?>\s* [0-9]+) |
9715             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9716             \$ \$ (?![\w\{]) |
9717             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9718             \[\^ |
9719             \[\: (?>[a-z]+) :\] |
9720             \[\:\^ (?>[a-z]+) :\] |
9721             \(\? |
9722             $q_char
9723             ))/oxmsg;
9724 142 50       36716  
9725 142         1118 # choice again delimiter
  0         0  
9726 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9727 0         0 my %octet = map {$_ => 1} @char;
9728 0         0 if (not $octet{')'}) {
9729             $delimiter = '(';
9730             $end_delimiter = ')';
9731 0         0 }
9732 0         0 elsif (not $octet{'}'}) {
9733             $delimiter = '{';
9734             $end_delimiter = '}';
9735 0         0 }
9736 0         0 elsif (not $octet{']'}) {
9737             $delimiter = '[';
9738             $end_delimiter = ']';
9739 0         0 }
9740 0         0 elsif (not $octet{'>'}) {
9741             $delimiter = '<';
9742             $end_delimiter = '>';
9743 0         0 }
9744 0 0       0 else {
9745 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9746 0         0 if (not $octet{$char}) {
9747 0         0 $delimiter = $char;
9748             $end_delimiter = $char;
9749             last;
9750             }
9751             }
9752             }
9753             }
9754 0         0  
  142         279  
9755             # count '('
9756 476         865 my $parens = grep { $_ eq '(' } @char;
9757 142         219  
9758 142         216 my $left_e = 0;
9759             my $right_e = 0;
9760             for (my $i=0; $i <= $#char; $i++) {
9761 142 50 33     480  
    50 33        
    100          
    100          
    50          
    50          
9762 397         2527 # "\L\u" --> "\u\L"
9763             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9764             @char[$i,$i+1] = @char[$i+1,$i];
9765             }
9766              
9767 0         0 # "\U\l" --> "\l\U"
9768             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9769             @char[$i,$i+1] = @char[$i+1,$i];
9770             }
9771              
9772 0         0 # octal escape sequence
9773             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9774             $char[$i] = Egbk::octchr($1);
9775             }
9776              
9777 1         3 # hexadecimal escape sequence
9778             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9779             $char[$i] = Egbk::hexchr($1);
9780             }
9781              
9782             # \b{...} --> b\{...}
9783             # \B{...} --> B\{...}
9784             # \N{CHARNAME} --> N\{CHARNAME}
9785             # \p{PROPERTY} --> p\{PROPERTY}
9786 1         3 # \P{PROPERTY} --> P\{PROPERTY}
9787             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9788             $char[$i] = $1 . '\\' . $2;
9789             }
9790              
9791 0         0 # \p, \P, \X --> p, P, X
9792             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9793             $char[$i] = $1;
9794 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          
9795              
9796             if (0) {
9797             }
9798 397         4486  
9799 0         0 # escape last octet of multiple-octet
9800             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9801             $char[$i] = $1 . '\\' . $2;
9802             }
9803              
9804 23 0 0     117 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
9805 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9806             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)) {
9807             $char[$i] .= join '', splice @char, $i+1, 3;
9808 0         0 }
9809             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)) {
9810             $char[$i] .= join '', splice @char, $i+1, 2;
9811 0         0 }
9812             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)) {
9813             $char[$i] .= join '', splice @char, $i+1, 1;
9814             }
9815             }
9816              
9817 0         0 # open character class [...]
9818 20 50       41 elsif ($char[$i] eq '[') {
9819 20         63 my $left = $i;
9820             if ($char[$i+1] eq ']') {
9821 0         0 $i++;
9822 20 50       40 }
9823 79         126 while (1) {
9824             if (++$i > $#char) {
9825 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9826 79         217 }
9827             if ($char[$i] eq ']') {
9828             my $right = $i;
9829 20 50       36  
9830 20         163 # [...]
  0         0  
9831             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9832             splice @char, $left, $right-$left+1, sprintf(q{@{[Egbk::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9833 0         0 }
9834             else {
9835             splice @char, $left, $right-$left+1, Egbk::charlist_qr(@char[$left+1..$right-1], $modifier);
9836 20         124 }
9837 20         39  
9838             $i = $left;
9839             last;
9840             }
9841             }
9842             }
9843              
9844 20         59 # open character class [^...]
9845 0 0       0 elsif ($char[$i] eq '[^') {
9846 0         0 my $left = $i;
9847             if ($char[$i+1] eq ']') {
9848 0         0 $i++;
9849 0 0       0 }
9850 0         0 while (1) {
9851             if (++$i > $#char) {
9852 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9853 0         0 }
9854             if ($char[$i] eq ']') {
9855             my $right = $i;
9856 0 0       0  
9857 0         0 # [^...]
  0         0  
9858             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9859             splice @char, $left, $right-$left+1, sprintf(q{@{[Egbk::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9860 0         0 }
9861             else {
9862             splice @char, $left, $right-$left+1, Egbk::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9863 0         0 }
9864 0         0  
9865             $i = $left;
9866             last;
9867             }
9868             }
9869             }
9870              
9871 0         0 # rewrite character class or escape character
9872             elsif (my $char = character_class($char[$i],$modifier)) {
9873             $char[$i] = $char;
9874             }
9875              
9876 11 50       30 # /i modifier
9877 11         21 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egbk::uc($char[$i]) ne Egbk::fc($char[$i]))) {
9878             if (CORE::length(Egbk::fc($char[$i])) == 1) {
9879             $char[$i] = '[' . Egbk::uc($char[$i]) . Egbk::fc($char[$i]) . ']';
9880 11         22 }
9881             else {
9882             $char[$i] = '(?:' . Egbk::uc($char[$i]) . '|' . Egbk::fc($char[$i]) . ')';
9883             }
9884             }
9885              
9886 0 50       0 # \u \l \U \L \F \Q \E
9887 8         25 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9888             if ($right_e < $left_e) {
9889             $char[$i] = '\\' . $char[$i];
9890             }
9891 0         0 }
9892 0         0 elsif ($char[$i] eq '\u') {
9893             $char[$i] = '@{[Egbk::ucfirst qq<';
9894             $left_e++;
9895 0         0 }
9896 0         0 elsif ($char[$i] eq '\l') {
9897             $char[$i] = '@{[Egbk::lcfirst qq<';
9898             $left_e++;
9899 0         0 }
9900 0         0 elsif ($char[$i] eq '\U') {
9901             $char[$i] = '@{[Egbk::uc qq<';
9902             $left_e++;
9903 0         0 }
9904 0         0 elsif ($char[$i] eq '\L') {
9905             $char[$i] = '@{[Egbk::lc qq<';
9906             $left_e++;
9907 0         0 }
9908 0         0 elsif ($char[$i] eq '\F') {
9909             $char[$i] = '@{[Egbk::fc qq<';
9910             $left_e++;
9911 0         0 }
9912 7         11 elsif ($char[$i] eq '\Q') {
9913             $char[$i] = '@{[CORE::quotemeta qq<';
9914             $left_e++;
9915 7 50       16 }
9916 7         15 elsif ($char[$i] eq '\E') {
9917 7         12 if ($right_e < $left_e) {
9918             $char[$i] = '>]}';
9919             $right_e++;
9920 7         14 }
9921             else {
9922             $char[$i] = '';
9923             }
9924 0         0 }
9925 0 0       0 elsif ($char[$i] eq '\Q') {
9926 0         0 while (1) {
9927             if (++$i > $#char) {
9928 0 0       0 last;
9929 0         0 }
9930             if ($char[$i] eq '\E') {
9931             last;
9932             }
9933             }
9934             }
9935             elsif ($char[$i] eq '\E') {
9936             }
9937              
9938             # \0 --> \0
9939             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
9940             }
9941              
9942             # \g{N}, \g{-N}
9943              
9944             # P.108 Using Simple Patterns
9945             # in Chapter 7: In the World of Regular Expressions
9946             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
9947              
9948             # P.221 Capturing
9949             # in Chapter 5: Pattern Matching
9950             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
9951              
9952             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
9953             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9954             }
9955              
9956 0 0       0 # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
9957 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9958             if ($1 <= $parens) {
9959             $char[$i] = '\\g{' . ($1 + 1) . '}';
9960             }
9961             }
9962              
9963 0 0       0 # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
9964 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9965             if ($1 <= $parens) {
9966             $char[$i] = '\\g' . ($1 + 1);
9967             }
9968             }
9969              
9970 0 0       0 # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
9971 0         0 elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9972             if ($1 <= $parens) {
9973             $char[$i] = '\\' . ($1 + 1);
9974             }
9975             }
9976              
9977 0 0       0 # $0 --> $0
9978 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9979             if ($ignorecase) {
9980             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9981             }
9982 0 0       0 }
9983 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9984             if ($ignorecase) {
9985             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9986             }
9987             }
9988              
9989             # $$ --> $$
9990             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9991             }
9992              
9993             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9994 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9995 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9996 0         0 $char[$i] = e_capture($1);
9997             if ($ignorecase) {
9998             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
9999             }
10000 0         0 }
10001 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10002 0         0 $char[$i] = e_capture($1);
10003             if ($ignorecase) {
10004             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10005             }
10006             }
10007              
10008 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10009 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) {
10010 0         0 $char[$i] = e_capture($1.'->'.$2);
10011             if ($ignorecase) {
10012             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10013             }
10014             }
10015              
10016 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10017 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) {
10018 0         0 $char[$i] = e_capture($1.'->'.$2);
10019             if ($ignorecase) {
10020             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10021             }
10022             }
10023              
10024 0         0 # $$foo
10025 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10026 0         0 $char[$i] = e_capture($1);
10027             if ($ignorecase) {
10028             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10029             }
10030             }
10031              
10032 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egbk::PREMATCH()
10033 4         16 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10034             if ($ignorecase) {
10035             $char[$i] = '@{[Egbk::ignorecase(Egbk::PREMATCH())]}';
10036 0         0 }
10037             else {
10038             $char[$i] = '@{[Egbk::PREMATCH()]}';
10039             }
10040             }
10041              
10042 4 50       15 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egbk::MATCH()
10043 4         16 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10044             if ($ignorecase) {
10045             $char[$i] = '@{[Egbk::ignorecase(Egbk::MATCH())]}';
10046 0         0 }
10047             else {
10048             $char[$i] = '@{[Egbk::MATCH()]}';
10049             }
10050             }
10051              
10052 4 50       17 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egbk::POSTMATCH()
10053 3         12 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10054             if ($ignorecase) {
10055             $char[$i] = '@{[Egbk::ignorecase(Egbk::POSTMATCH())]}';
10056 0         0 }
10057             else {
10058             $char[$i] = '@{[Egbk::POSTMATCH()]}';
10059             }
10060             }
10061              
10062 3 0       13 # ${ foo }
10063 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) {
10064             if ($ignorecase) {
10065             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10066             }
10067             }
10068              
10069 0         0 # ${ ... }
10070 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10071 0         0 $char[$i] = e_capture($1);
10072             if ($ignorecase) {
10073             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10074             }
10075             }
10076              
10077 0         0 # $scalar or @array
10078 13 50       47 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10079 13         61 $char[$i] = e_string($char[$i]);
10080             if ($ignorecase) {
10081             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10082             }
10083             }
10084              
10085 0 50       0 # quote character before ? + * {
10086             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10087             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10088 23         129 }
10089             else {
10090             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10091             }
10092             }
10093             }
10094 23         125  
10095 142         326 # make regexp string
10096 142         337 my $prematch = '';
10097 142 50       231 $prematch = "($anchor)";
10098 142         418 $modifier =~ tr/i//d;
10099             if ($left_e > $right_e) {
10100 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
10101             }
10102             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10103             }
10104              
10105             #
10106             # escape regexp (s'here'' or s'here''b)
10107 142     96 0 1509 #
10108 96   100     214 sub e_s1_q {
10109             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10110 96         241 $modifier ||= '';
10111 96 50       112  
10112 96         248 $modifier =~ tr/p//d;
10113 0         0 if ($modifier =~ /([adlu])/oxms) {
10114 0 0       0 my $line = 0;
10115 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10116 0         0 if ($filename ne __FILE__) {
10117             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10118             last;
10119 0         0 }
10120             }
10121             die qq{Unsupported modifier "$1" used at line $line.\n};
10122 0         0 }
10123              
10124             $slash = 'div';
10125 96 100       128  
    100          
10126 96         220 # literal null string pattern
10127 8         9 if ($string eq '') {
10128 8         10 $modifier =~ tr/bB//d;
10129             $modifier =~ tr/i//d;
10130             return join '', $ope, $delimiter, $end_delimiter, $modifier;
10131             }
10132              
10133 8         47 # with /b /B modifier
10134             elsif ($modifier =~ tr/bB//d) {
10135             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
10136             }
10137              
10138 44         72 # without /b /B modifier
10139             else {
10140             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
10141             }
10142             }
10143              
10144             #
10145             # escape regexp (s'here'')
10146 44     44 0 90 #
10147             sub e_s1_qt {
10148 44 100       84 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10149              
10150             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10151 44         88  
10152             # split regexp
10153             my @char = $string =~ /\G((?>
10154             [^\x81-\xFE\\\[\$\@\/] |
10155             [\x81-\xFE][\x00-\xFF] |
10156             \[\^ |
10157             \[\: (?>[a-z]+) \:\] |
10158             \[\:\^ (?>[a-z]+) \:\] |
10159             [\$\@\/] |
10160             \\ (?:$q_char) |
10161             (?:$q_char)
10162             ))/oxmsg;
10163 44         479  
10164 44 50 100     114 # unescape character
    50 100        
    50 66        
    50          
    100          
    100          
    50          
10165             for (my $i=0; $i <= $#char; $i++) {
10166             if (0) {
10167             }
10168 62         486  
10169 0         0 # escape last octet of multiple-octet
10170             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10171             $char[$i] = $1 . '\\' . $2;
10172             }
10173              
10174 0         0 # open character class [...]
10175 0 0       0 elsif ($char[$i] eq '[') {
10176 0         0 my $left = $i;
10177             if ($char[$i+1] eq ']') {
10178 0         0 $i++;
10179 0 0       0 }
10180 0         0 while (1) {
10181             if (++$i > $#char) {
10182 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10183 0         0 }
10184             if ($char[$i] eq ']') {
10185             my $right = $i;
10186 0         0  
10187             # [...]
10188 0         0 splice @char, $left, $right-$left+1, Egbk::charlist_qr(@char[$left+1..$right-1], $modifier);
10189 0         0  
10190             $i = $left;
10191             last;
10192             }
10193             }
10194             }
10195              
10196 0         0 # open character class [^...]
10197 0 0       0 elsif ($char[$i] eq '[^') {
10198 0         0 my $left = $i;
10199             if ($char[$i+1] eq ']') {
10200 0         0 $i++;
10201 0 0       0 }
10202 0         0 while (1) {
10203             if (++$i > $#char) {
10204 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10205 0         0 }
10206             if ($char[$i] eq ']') {
10207             my $right = $i;
10208 0         0  
10209             # [^...]
10210 0         0 splice @char, $left, $right-$left+1, Egbk::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10211 0         0  
10212             $i = $left;
10213             last;
10214             }
10215             }
10216             }
10217              
10218 0         0 # escape $ @ / and \
10219             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10220             $char[$i] = '\\' . $char[$i];
10221             }
10222              
10223 0         0 # rewrite character class or escape character
10224             elsif (my $char = character_class($char[$i],$modifier)) {
10225             $char[$i] = $char;
10226             }
10227              
10228 6 50       13 # /i modifier
10229 8         18 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egbk::uc($char[$i]) ne Egbk::fc($char[$i]))) {
10230             if (CORE::length(Egbk::fc($char[$i])) == 1) {
10231             $char[$i] = '[' . Egbk::uc($char[$i]) . Egbk::fc($char[$i]) . ']';
10232 8         15 }
10233             else {
10234             $char[$i] = '(?:' . Egbk::uc($char[$i]) . '|' . Egbk::fc($char[$i]) . ')';
10235             }
10236             }
10237              
10238 0 0       0 # quote character before ? + * {
10239             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10240             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
10241 0         0 }
10242             else {
10243             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10244             }
10245             }
10246 0         0 }
10247 44         84  
10248 44         61 $modifier =~ tr/i//d;
10249 44         47 $delimiter = '/';
10250 44         52 $end_delimiter = '/';
10251 44         79 my $prematch = '';
10252             $prematch = "($anchor)";
10253             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10254             }
10255              
10256             #
10257             # escape regexp (s'here''b)
10258 44     44 0 276 #
10259             sub e_s1_qb {
10260             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10261 44         79  
10262             # split regexp
10263             my @char = $string =~ /\G (?>[^\\]|\\\\|[\x00-\xFF]) /oxmsg;
10264 44         149  
10265 44 50       100 # unescape character
    50          
10266             for (my $i=0; $i <= $#char; $i++) {
10267             if (0) {
10268             }
10269 98         264  
10270             # remain \\
10271             elsif ($char[$i] eq '\\\\') {
10272             }
10273              
10274 0         0 # escape $ @ / and \
10275             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10276             $char[$i] = '\\' . $char[$i];
10277             }
10278 0         0 }
10279 44         57  
10280 44         49 $delimiter = '/';
10281 44         69 $end_delimiter = '/';
10282 44         52 my $prematch = '';
10283             $prematch = q{(\G[\x00-\xFF]*?)};
10284             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10285             }
10286              
10287             #
10288             # escape regexp (s''here')
10289 44     91 0 285 #
10290             sub e_s2_q {
10291 91         156 my($ope,$delimiter,$end_delimiter,$string) = @_;
10292              
10293 91         102 $slash = 'div';
10294 91         290  
10295 91 50 66     203 my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\\\|$q_char) /oxmsg;
    50 33        
    100          
    100          
10296             for (my $i=0; $i <= $#char; $i++) {
10297             if (0) {
10298             }
10299 9         89  
10300 0         0 # escape last octet of multiple-octet
10301             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10302             $char[$i] = $1 . '\\' . $2;
10303 0         0 }
10304             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10305             $char[$i] = $1 . '\\' . $2;
10306             }
10307              
10308             # not escape \\
10309             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
10310             }
10311              
10312 0         0 # escape $ @ / and \
10313             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10314             $char[$i] = '\\' . $char[$i];
10315 5 50 66     15 }
10316 91         202 }
10317             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10318             $char[-1] = $1 . '\\' . $2;
10319 0         0 }
10320              
10321             return join '', $ope, $delimiter, @char, $end_delimiter;
10322             }
10323              
10324             #
10325             # escape regexp (s/here/and here/modifier)
10326 91     290 0 242 #
10327 290   100     1798 sub e_sub {
10328             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
10329 290         1096 $modifier ||= '';
10330 290 50       513  
10331 290         886 $modifier =~ tr/p//d;
10332 0         0 if ($modifier =~ /([adlu])/oxms) {
10333 0 0       0 my $line = 0;
10334 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10335 0         0 if ($filename ne __FILE__) {
10336             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10337             last;
10338 0         0 }
10339             }
10340             die qq{Unsupported modifier "$1" used at line $line.\n};
10341 0 100       0 }
10342 290         637  
10343 37         50 if ($variable eq '') {
10344             $variable = '$_';
10345             $bind_operator = ' =~ ';
10346 37         46 }
10347              
10348             $slash = 'div';
10349              
10350             # P.128 Start of match (or end of previous match): \G
10351             # P.130 Advanced Use of \G with Perl
10352             # in Chapter 3: Overview of Regular Expression Features and Flavors
10353             # P.312 Iterative Matching: Scalar Context, with /g
10354             # in Chapter 7: Perl
10355             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
10356              
10357             # P.181 Where You Left Off: The \G Assertion
10358             # in Chapter 5: Pattern Matching
10359             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10360              
10361             # P.220 Where You Left Off: The \G Assertion
10362             # in Chapter 5: Pattern Matching
10363 290         391 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10364 290         422  
10365             my $e_modifier = $modifier =~ tr/e//d;
10366 290         391 my $r_modifier = $modifier =~ tr/r//d;
10367 290 50       394  
10368 290         653 my $my = '';
10369 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
10370 0         0 $my = $variable;
10371             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
10372             $variable =~ s/ = .+ \z//oxms;
10373 0         0 }
10374 290         619  
10375             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
10376             $variable_basename =~ s/ \s+ \z//oxms;
10377 290         483  
10378 290 100       410 # quote replacement string
10379 290         621 my $e_replacement = '';
10380 17         33 if ($e_modifier >= 1) {
10381             $e_replacement = e_qq('', '', '', $replacement);
10382             $e_modifier--;
10383 17 100       24 }
10384 273         538 else {
10385             if ($delimiter2 eq "'") {
10386             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
10387 91         153 }
10388             else {
10389             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
10390             }
10391 182         436 }
10392              
10393             my $sub = '';
10394 290 100       468  
10395 290 100       556 # with /r
    50          
10396             if ($r_modifier) {
10397             if (0) {
10398             }
10399 8         34  
10400 0 50       0 # s///gr with multibyte anchoring
10401             elsif ($modifier =~ /g/oxms) {
10402             $sub = sprintf(
10403             # 1 2 3 4 5
10404             q,
10405              
10406             $variable, # 1
10407             ($delimiter1 eq "'") ? # 2
10408             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10409             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10410             $s_matched, # 3
10411             $e_replacement, # 4
10412             '$Egbk::re_r=CORE::eval $Egbk::re_r; ' x $e_modifier, # 5
10413             );
10414             }
10415              
10416 4 0       23 # s///gr without multibyte anchoring
10417             elsif ($modifier =~ /g/oxms) {
10418             $sub = sprintf(
10419             # 1 2 3 4 5
10420             q,
10421              
10422             $variable, # 1
10423             ($delimiter1 eq "'") ? # 2
10424             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10425             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10426             $s_matched, # 3
10427             $e_replacement, # 4
10428             '$Egbk::re_r=CORE::eval $Egbk::re_r; ' x $e_modifier, # 5
10429             );
10430             }
10431              
10432             # s///r
10433 0         0 else {
10434 4         7  
10435             my $prematch = q{$`};
10436 4 50       7 $prematch = q{${1}};
10437              
10438             $sub = sprintf(
10439             # 1 2 3 4 5 6 7
10440             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Egbk::re_r=%s; %s"%s$Egbk::re_r$'" } : %s>,
10441              
10442             $variable, # 1
10443             ($delimiter1 eq "'") ? # 2
10444             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10445             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10446             $s_matched, # 3
10447             $e_replacement, # 4
10448             '$Egbk::re_r=CORE::eval $Egbk::re_r; ' x $e_modifier, # 5
10449             $prematch, # 6
10450             $variable, # 7
10451             );
10452             }
10453 4 50       19  
10454 8         27 # $var !~ s///r doesn't make sense
10455             if ($bind_operator =~ / !~ /oxms) {
10456             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
10457             }
10458             }
10459              
10460 0 100       0 # without /r
    50          
10461             else {
10462             if (0) {
10463             }
10464 282         699  
10465 0 100       0 # s///g with multibyte anchoring
    100          
10466             elsif ($modifier =~ /g/oxms) {
10467             $sub = sprintf(
10468             # 1 2 3 4 5 6 7 8 9 10
10469             q,
10470              
10471             $variable, # 1
10472             ($delimiter1 eq "'") ? # 2
10473             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10474             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10475             $s_matched, # 3
10476             $e_replacement, # 4
10477             '$Egbk::re_r=CORE::eval $Egbk::re_r; ' x $e_modifier, # 5
10478             $variable, # 6
10479             $variable, # 7
10480             $variable, # 8
10481             $variable, # 9
10482              
10483             # Binary "!~" is just like "=~" except the return value is negated in the logical sense.
10484             # It returns false if the match succeeds, and true if it fails.
10485             # (and so on)
10486              
10487             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 10
10488             );
10489             }
10490              
10491 35 0       151 # s///g without multibyte anchoring
    0          
10492             elsif ($modifier =~ /g/oxms) {
10493             $sub = sprintf(
10494             # 1 2 3 4 5 6 7 8
10495             q,
10496              
10497             $variable, # 1
10498             ($delimiter1 eq "'") ? # 2
10499             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10500             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10501             $s_matched, # 3
10502             $e_replacement, # 4
10503             '$Egbk::re_r=CORE::eval $Egbk::re_r; ' x $e_modifier, # 5
10504             $variable, # 6
10505             $variable, # 7
10506             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
10507             );
10508             }
10509              
10510             # s///
10511 0         0 else {
10512 247         465  
10513             my $prematch = q{$`};
10514 247 100       320 $prematch = q{${1}};
    100          
10515              
10516             $sub = sprintf(
10517              
10518             ($bind_operator =~ / =~ /oxms) ?
10519              
10520             # 1 2 3 4 5 6 7 8
10521             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Egbk::re_r=%s; %s%s="%s$Egbk::re_r$'"; 1 } : undef> :
10522              
10523             # 1 2 3 4 5 6 7 8
10524             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Egbk::re_r=%s; %s%s="%s$Egbk::re_r$'"; undef }>,
10525              
10526             $variable, # 1
10527             $bind_operator, # 2
10528             ($delimiter1 eq "'") ? # 3
10529             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10530             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10531             $s_matched, # 4
10532             $e_replacement, # 5
10533             '$Egbk::re_r=CORE::eval $Egbk::re_r; ' x $e_modifier, # 6
10534             $variable, # 7
10535             $prematch, # 8
10536             );
10537             }
10538             }
10539 247 50       1129  
10540 290         772 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
10541             if ($my ne '') {
10542             $sub = "($my, $sub)[1]";
10543             }
10544 0         0  
10545 290         398 # clear s/// variable
10546             $sub_variable = '';
10547 290         380 $bind_operator = '';
10548              
10549             return $sub;
10550             }
10551              
10552             #
10553             # escape chdir (qq//, "")
10554 290     0 0 2309 #
10555             sub e_chdir {
10556 0 0       0 my($ope,$delimiter,$end_delimiter,$string) = @_;
10557 0 0       0  
10558 0 0       0 if ($^W) {
10559 0         0 if (Egbk::_MSWin32_5Cended_path($string)) {
10560 0         0 if ($] !~ /^5\.005/oxms) {
10561             warn <
10562             @{[__FILE__]}: Can't chdir to '$string'
10563              
10564             chdir does not work with chr(0x5C) at end of path
10565             http://bugs.activestate.com/show_bug.cgi?id=81839
10566             END
10567             }
10568             }
10569 0         0 }
10570              
10571             return e_qq($ope,$delimiter,$end_delimiter,$string);
10572             }
10573              
10574             #
10575             # escape chdir (q//, '')
10576 0     2 0 0 #
10577             sub e_chdir_q {
10578 2 50       6 my($ope,$delimiter,$end_delimiter,$string) = @_;
10579 2 0       7  
10580 0 0       0 if ($^W) {
10581 0         0 if (Egbk::_MSWin32_5Cended_path($string)) {
10582 0         0 if ($] !~ /^5\.005/oxms) {
10583             warn <
10584             @{[__FILE__]}: Can't chdir to '$string'
10585              
10586             chdir does not work with chr(0x5C) at end of path
10587             http://bugs.activestate.com/show_bug.cgi?id=81839
10588             END
10589             }
10590             }
10591 0         0 }
10592              
10593             return e_q($ope,$delimiter,$end_delimiter,$string);
10594             }
10595              
10596             #
10597             # escape regexp of split qr//
10598 2     273 0 12 #
10599 273   100     1190 sub e_split {
10600             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10601 273         939 $modifier ||= '';
10602 273 50       462  
10603 273         637 $modifier =~ tr/p//d;
10604 0         0 if ($modifier =~ /([adlu])/oxms) {
10605 0 0       0 my $line = 0;
10606 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10607 0         0 if ($filename ne __FILE__) {
10608             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10609             last;
10610 0         0 }
10611             }
10612             die qq{Unsupported modifier "$1" used at line $line.\n};
10613 0         0 }
10614              
10615             $slash = 'div';
10616 273 100       400  
10617 273         538 # /b /B modifier
10618             if ($modifier =~ tr/bB//d) {
10619             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10620 84 100       418 }
10621 189         625  
10622             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10623             my $metachar = qr/[\@\\|[\]{^]/oxms;
10624 189         628  
10625             # split regexp
10626             my @char = $string =~ /\G((?>
10627             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
10628             \\x (?>[0-9A-Fa-f]{1,2}) |
10629             \\ (?>[0-7]{2,3}) |
10630             \\c [\x40-\x5F] |
10631             \\x\{ (?>[0-9A-Fa-f]+) \} |
10632             \\o\{ (?>[0-7]+) \} |
10633             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
10634             \\ $q_char |
10635             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
10636             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
10637             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
10638             [\$\@] $qq_variable |
10639             \$ (?>\s* [0-9]+) |
10640             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
10641             \$ \$ (?![\w\{]) |
10642             \$ (?>\s*) \$ (?>\s*) $qq_variable |
10643             \[\^ |
10644             \[\: (?>[a-z]+) :\] |
10645             \[\:\^ (?>[a-z]+) :\] |
10646             \(\? |
10647             $q_char
10648 189         18530 ))/oxmsg;
10649 189         585  
10650 189         326 my $left_e = 0;
10651             my $right_e = 0;
10652             for (my $i=0; $i <= $#char; $i++) {
10653 189 50 33     489  
    50 33        
    100          
    100          
    50          
    50          
10654 372         2222 # "\L\u" --> "\u\L"
10655             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
10656             @char[$i,$i+1] = @char[$i+1,$i];
10657             }
10658              
10659 0         0 # "\U\l" --> "\l\U"
10660             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
10661             @char[$i,$i+1] = @char[$i+1,$i];
10662             }
10663              
10664 0         0 # octal escape sequence
10665             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
10666             $char[$i] = Egbk::octchr($1);
10667             }
10668              
10669 1         3 # hexadecimal escape sequence
10670             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
10671             $char[$i] = Egbk::hexchr($1);
10672             }
10673              
10674             # \b{...} --> b\{...}
10675             # \B{...} --> B\{...}
10676             # \N{CHARNAME} --> N\{CHARNAME}
10677             # \p{PROPERTY} --> p\{PROPERTY}
10678 1         4 # \P{PROPERTY} --> P\{PROPERTY}
10679             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
10680             $char[$i] = $1 . '\\' . $2;
10681             }
10682              
10683 0         0 # \p, \P, \X --> p, P, X
10684             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
10685             $char[$i] = $1;
10686 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          
10687              
10688             if (0) {
10689             }
10690 372         3293  
10691 0         0 # escape last octet of multiple-octet
10692             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10693             $char[$i] = $1 . '\\' . $2;
10694             }
10695              
10696 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
10697 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
10698             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)) {
10699             $char[$i] .= join '', splice @char, $i+1, 3;
10700 0         0 }
10701             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)) {
10702             $char[$i] .= join '', splice @char, $i+1, 2;
10703 0         0 }
10704             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)) {
10705             $char[$i] .= join '', splice @char, $i+1, 1;
10706             }
10707             }
10708              
10709 0         0 # open character class [...]
10710 3 50       7 elsif ($char[$i] eq '[') {
10711 3         8 my $left = $i;
10712             if ($char[$i+1] eq ']') {
10713 0         0 $i++;
10714 3 50       6 }
10715 7         13 while (1) {
10716             if (++$i > $#char) {
10717 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10718 7         32 }
10719             if ($char[$i] eq ']') {
10720             my $right = $i;
10721 3 50       4  
10722 3         20 # [...]
  0         0  
10723             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10724             splice @char, $left, $right-$left+1, sprintf(q{@{[Egbk::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10725 0         0 }
10726             else {
10727             splice @char, $left, $right-$left+1, Egbk::charlist_qr(@char[$left+1..$right-1], $modifier);
10728 3         17 }
10729 3         6  
10730             $i = $left;
10731             last;
10732             }
10733             }
10734             }
10735              
10736 3         9 # open character class [^...]
10737 1 50       3 elsif ($char[$i] eq '[^') {
10738 1         4 my $left = $i;
10739             if ($char[$i+1] eq ']') {
10740 0         0 $i++;
10741 1 50       1 }
10742 2         5 while (1) {
10743             if (++$i > $#char) {
10744 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10745 2         6 }
10746             if ($char[$i] eq ']') {
10747             my $right = $i;
10748 1 50       2  
10749 1         7 # [^...]
  0         0  
10750             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10751             splice @char, $left, $right-$left+1, sprintf(q{@{[Egbk::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10752 0         0 }
10753             else {
10754             splice @char, $left, $right-$left+1, Egbk::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10755 1         15 }
10756 1         2  
10757             $i = $left;
10758             last;
10759             }
10760             }
10761             }
10762              
10763 1         9 # rewrite character class or escape character
10764             elsif (my $char = character_class($char[$i],$modifier)) {
10765             $char[$i] = $char;
10766             }
10767              
10768             # P.794 29.2.161. split
10769             # in Chapter 29: Functions
10770             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10771              
10772             # P.951 split
10773             # in Chapter 27: Functions
10774             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10775              
10776             # said "The //m modifier is assumed when you split on the pattern /^/",
10777             # but perl5.008 is not so. Therefore, this software adds //m.
10778             # (and so on)
10779              
10780 5         18 # split(m/^/) --> split(m/^/m)
10781             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
10782             $modifier .= 'm';
10783             }
10784              
10785 11 50       41 # /i modifier
10786 18         40 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egbk::uc($char[$i]) ne Egbk::fc($char[$i]))) {
10787             if (CORE::length(Egbk::fc($char[$i])) == 1) {
10788             $char[$i] = '[' . Egbk::uc($char[$i]) . Egbk::fc($char[$i]) . ']';
10789 18         41 }
10790             else {
10791             $char[$i] = '(?:' . Egbk::uc($char[$i]) . '|' . Egbk::fc($char[$i]) . ')';
10792             }
10793             }
10794              
10795 0 50       0 # \u \l \U \L \F \Q \E
10796 2         9 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
10797             if ($right_e < $left_e) {
10798             $char[$i] = '\\' . $char[$i];
10799             }
10800 0         0 }
10801 0         0 elsif ($char[$i] eq '\u') {
10802             $char[$i] = '@{[Egbk::ucfirst qq<';
10803             $left_e++;
10804 0         0 }
10805 0         0 elsif ($char[$i] eq '\l') {
10806             $char[$i] = '@{[Egbk::lcfirst qq<';
10807             $left_e++;
10808 0         0 }
10809 0         0 elsif ($char[$i] eq '\U') {
10810             $char[$i] = '@{[Egbk::uc qq<';
10811             $left_e++;
10812 0         0 }
10813 0         0 elsif ($char[$i] eq '\L') {
10814             $char[$i] = '@{[Egbk::lc qq<';
10815             $left_e++;
10816 0         0 }
10817 0         0 elsif ($char[$i] eq '\F') {
10818             $char[$i] = '@{[Egbk::fc qq<';
10819             $left_e++;
10820 0         0 }
10821 0         0 elsif ($char[$i] eq '\Q') {
10822             $char[$i] = '@{[CORE::quotemeta qq<';
10823             $left_e++;
10824 0 0       0 }
10825 0         0 elsif ($char[$i] eq '\E') {
10826 0         0 if ($right_e < $left_e) {
10827             $char[$i] = '>]}';
10828             $right_e++;
10829 0         0 }
10830             else {
10831             $char[$i] = '';
10832             }
10833 0         0 }
10834 0 0       0 elsif ($char[$i] eq '\Q') {
10835 0         0 while (1) {
10836             if (++$i > $#char) {
10837 0 0       0 last;
10838 0         0 }
10839             if ($char[$i] eq '\E') {
10840             last;
10841             }
10842             }
10843             }
10844             elsif ($char[$i] eq '\E') {
10845             }
10846              
10847 0 0       0 # $0 --> $0
10848 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
10849             if ($ignorecase) {
10850             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10851             }
10852 0 0       0 }
10853 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
10854             if ($ignorecase) {
10855             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10856             }
10857             }
10858              
10859             # $$ --> $$
10860             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10861             }
10862              
10863             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10864 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
10865 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10866 0         0 $char[$i] = e_capture($1);
10867             if ($ignorecase) {
10868             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10869             }
10870 0         0 }
10871 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10872 0         0 $char[$i] = e_capture($1);
10873             if ($ignorecase) {
10874             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10875             }
10876             }
10877              
10878 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10879 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) {
10880 0         0 $char[$i] = e_capture($1.'->'.$2);
10881             if ($ignorecase) {
10882             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10883             }
10884             }
10885              
10886 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10887 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) {
10888 0         0 $char[$i] = e_capture($1.'->'.$2);
10889             if ($ignorecase) {
10890             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10891             }
10892             }
10893              
10894 0         0 # $$foo
10895 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10896 0         0 $char[$i] = e_capture($1);
10897             if ($ignorecase) {
10898             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10899             }
10900             }
10901              
10902 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egbk::PREMATCH()
10903 12         32 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10904             if ($ignorecase) {
10905             $char[$i] = '@{[Egbk::ignorecase(Egbk::PREMATCH())]}';
10906 0         0 }
10907             else {
10908             $char[$i] = '@{[Egbk::PREMATCH()]}';
10909             }
10910             }
10911              
10912 12 50       52 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egbk::MATCH()
10913 12         35 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10914             if ($ignorecase) {
10915             $char[$i] = '@{[Egbk::ignorecase(Egbk::MATCH())]}';
10916 0         0 }
10917             else {
10918             $char[$i] = '@{[Egbk::MATCH()]}';
10919             }
10920             }
10921              
10922 12 50       60 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egbk::POSTMATCH()
10923 9         21 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10924             if ($ignorecase) {
10925             $char[$i] = '@{[Egbk::ignorecase(Egbk::POSTMATCH())]}';
10926 0         0 }
10927             else {
10928             $char[$i] = '@{[Egbk::POSTMATCH()]}';
10929             }
10930             }
10931              
10932 9 0       45 # ${ foo }
10933 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) {
10934             if ($ignorecase) {
10935             $char[$i] = '@{[Egbk::ignorecase(' . $1 . ')]}';
10936             }
10937             }
10938              
10939 0         0 # ${ ... }
10940 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10941 0         0 $char[$i] = e_capture($1);
10942             if ($ignorecase) {
10943             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10944             }
10945             }
10946              
10947 0         0 # $scalar or @array
10948 3 50       11 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10949 3         15 $char[$i] = e_string($char[$i]);
10950             if ($ignorecase) {
10951             $char[$i] = '@{[Egbk::ignorecase(' . $char[$i] . ')]}';
10952             }
10953             }
10954              
10955 0 100       0 # quote character before ? + * {
10956             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10957             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10958 7         40 }
10959             else {
10960             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10961             }
10962             }
10963             }
10964 4         25  
10965 189 50       390 # make regexp string
10966 189         377 $modifier =~ tr/i//d;
10967             if ($left_e > $right_e) {
10968 0         0 return join '', 'Egbk::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
10969             }
10970             return join '', 'Egbk::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
10971             }
10972              
10973             #
10974             # escape regexp of split qr''
10975 189     112 0 1677 #
10976 112   100     523 sub e_split_q {
10977             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10978 112         334 $modifier ||= '';
10979 112 50       201  
10980 112         294 $modifier =~ tr/p//d;
10981 0         0 if ($modifier =~ /([adlu])/oxms) {
10982 0 0       0 my $line = 0;
10983 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10984 0         0 if ($filename ne __FILE__) {
10985             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10986             last;
10987 0         0 }
10988             }
10989             die qq{Unsupported modifier "$1" used at line $line.\n};
10990 0         0 }
10991              
10992             $slash = 'div';
10993 112 100       172  
10994 112         220 # /b /B modifier
10995             if ($modifier =~ tr/bB//d) {
10996             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10997 56 100       284 }
10998              
10999             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
11000 56         146  
11001             # split regexp
11002             my @char = $string =~ /\G((?>
11003             [^\x81-\xFE\\\[] |
11004             [\x81-\xFE][\x00-\xFF] |
11005             \[\^ |
11006             \[\: (?>[a-z]+) \:\] |
11007             \[\:\^ (?>[a-z]+) \:\] |
11008             \\ (?:$q_char) |
11009             (?:$q_char)
11010             ))/oxmsg;
11011 56         365  
11012 56 50 33     166 # unescape character
    50 100        
    50 66        
    50 33        
    50          
    100          
    50          
11013             for (my $i=0; $i <= $#char; $i++) {
11014             if (0) {
11015             }
11016 56         510  
11017 0         0 # escape last octet of multiple-octet
11018             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
11019             $char[$i] = $1 . '\\' . $2;
11020             }
11021              
11022 0         0 # open character class [...]
11023 0 0       0 elsif ($char[$i] eq '[') {
11024 0         0 my $left = $i;
11025             if ($char[$i+1] eq ']') {
11026 0         0 $i++;
11027 0 0       0 }
11028 0         0 while (1) {
11029             if (++$i > $#char) {
11030 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11031 0         0 }
11032             if ($char[$i] eq ']') {
11033             my $right = $i;
11034 0         0  
11035             # [...]
11036 0         0 splice @char, $left, $right-$left+1, Egbk::charlist_qr(@char[$left+1..$right-1], $modifier);
11037 0         0  
11038             $i = $left;
11039             last;
11040             }
11041             }
11042             }
11043              
11044 0         0 # open character class [^...]
11045 0 0       0 elsif ($char[$i] eq '[^') {
11046 0         0 my $left = $i;
11047             if ($char[$i+1] eq ']') {
11048 0         0 $i++;
11049 0 0       0 }
11050 0         0 while (1) {
11051             if (++$i > $#char) {
11052 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11053 0         0 }
11054             if ($char[$i] eq ']') {
11055             my $right = $i;
11056 0         0  
11057             # [^...]
11058 0         0 splice @char, $left, $right-$left+1, Egbk::charlist_not_qr(@char[$left+1..$right-1], $modifier);
11059 0         0  
11060             $i = $left;
11061             last;
11062             }
11063             }
11064             }
11065              
11066 0         0 # rewrite character class or escape character
11067             elsif (my $char = character_class($char[$i],$modifier)) {
11068             $char[$i] = $char;
11069             }
11070              
11071 0         0 # split(m/^/) --> split(m/^/m)
11072             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
11073             $modifier .= 'm';
11074             }
11075              
11076 0 50       0 # /i modifier
11077 12         32 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egbk::uc($char[$i]) ne Egbk::fc($char[$i]))) {
11078             if (CORE::length(Egbk::fc($char[$i])) == 1) {
11079             $char[$i] = '[' . Egbk::uc($char[$i]) . Egbk::fc($char[$i]) . ']';
11080 12         31 }
11081             else {
11082             $char[$i] = '(?:' . Egbk::uc($char[$i]) . '|' . Egbk::fc($char[$i]) . ')';
11083             }
11084             }
11085              
11086 0 0       0 # quote character before ? + * {
11087             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
11088             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
11089 0         0 }
11090             else {
11091             $char[$i-1] = '(?:' . $char[$i-1] . ')';
11092             }
11093             }
11094 0         0 }
11095 56         151  
11096             $modifier =~ tr/i//d;
11097             return join '', 'Egbk::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
11098             }
11099              
11100             #
11101             # escape use without import
11102 56     0 0 316 #
11103             sub e_use_noimport {
11104 0           my($module) = @_;
11105              
11106 0           my $expr = _pathof($module);
11107 0            
11108             my $fh = gensym();
11109 0 0         for my $realfilename (_realfilename($expr)) {
11110 0            
11111 0           if (Egbk::_open_r($fh, $realfilename)) {
11112 0 0         local $/ = undef; # slurp mode
11113             my $script = <$fh>;
11114 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11115 0            
11116             if ($script =~ /^ (?>\s*) use (?>\s+) GBK (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11117 0           return qq;
11118             }
11119             last;
11120             }
11121 0           }
11122              
11123             return qq;
11124             }
11125              
11126             #
11127             # escape no without unimport
11128 0     0 0   #
11129             sub e_no_nounimport {
11130 0           my($module) = @_;
11131              
11132 0           my $expr = _pathof($module);
11133 0            
11134             my $fh = gensym();
11135 0 0         for my $realfilename (_realfilename($expr)) {
11136 0            
11137 0           if (Egbk::_open_r($fh, $realfilename)) {
11138 0 0         local $/ = undef; # slurp mode
11139             my $script = <$fh>;
11140 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11141 0            
11142             if ($script =~ /^ (?>\s*) use (?>\s+) GBK (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11143 0           return qq;
11144             }
11145             last;
11146             }
11147 0           }
11148              
11149             return qq;
11150             }
11151              
11152             #
11153             # escape use with import no parameter
11154 0     0 0   #
11155             sub e_use_noparam {
11156 0           my($module) = @_;
11157              
11158 0           my $expr = _pathof($module);
11159 0            
11160             my $fh = gensym();
11161 0 0         for my $realfilename (_realfilename($expr)) {
11162 0            
11163 0           if (Egbk::_open_r($fh, $realfilename)) {
11164 0 0         local $/ = undef; # slurp mode
11165             my $script = <$fh>;
11166 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11167              
11168             if ($script =~ /^ (?>\s*) use (?>\s+) GBK (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11169              
11170             # P.326 UNIVERSAL: The Ultimate Ancestor Class
11171             # in Chapter 12: Objects
11172             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
11173              
11174             # P.435 UNIVERSAL: The Ultimate Ancestor Class
11175             # in Chapter 12: Objects
11176             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
11177              
11178 0           # (and so on)
11179              
11180 0           return qq[BEGIN { Egbk::require '$expr'; $module->import() if $module->can('import'); }];
11181             }
11182             last;
11183             }
11184 0           }
11185              
11186             return qq;
11187             }
11188              
11189             #
11190             # escape no with unimport no parameter
11191 0     0 0   #
11192             sub e_no_noparam {
11193 0           my($module) = @_;
11194              
11195 0           my $expr = _pathof($module);
11196 0            
11197             my $fh = gensym();
11198 0 0         for my $realfilename (_realfilename($expr)) {
11199 0            
11200 0           if (Egbk::_open_r($fh, $realfilename)) {
11201 0 0         local $/ = undef; # slurp mode
11202             my $script = <$fh>;
11203 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11204 0            
11205             if ($script =~ /^ (?>\s*) use (?>\s+) GBK (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11206 0           return qq[BEGIN { Egbk::require '$expr'; $module->unimport() if $module->can('unimport'); }];
11207             }
11208             last;
11209             }
11210 0           }
11211              
11212             return qq;
11213             }
11214              
11215             #
11216             # escape use with import parameters
11217 0     0 0   #
11218             sub e_use {
11219 0           my($module,$list) = @_;
11220              
11221 0           my $expr = _pathof($module);
11222 0            
11223             my $fh = gensym();
11224 0 0         for my $realfilename (_realfilename($expr)) {
11225 0            
11226 0           if (Egbk::_open_r($fh, $realfilename)) {
11227 0 0         local $/ = undef; # slurp mode
11228             my $script = <$fh>;
11229 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11230 0            
11231             if ($script =~ /^ (?>\s*) use (?>\s+) GBK (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11232 0           return qq[BEGIN { Egbk::require '$expr'; $module->import($list) if $module->can('import'); }];
11233             }
11234             last;
11235             }
11236 0           }
11237              
11238             return qq;
11239             }
11240              
11241             #
11242             # escape no with unimport parameters
11243 0     0 0   #
11244             sub e_no {
11245 0           my($module,$list) = @_;
11246              
11247 0           my $expr = _pathof($module);
11248 0            
11249             my $fh = gensym();
11250 0 0         for my $realfilename (_realfilename($expr)) {
11251 0            
11252 0           if (Egbk::_open_r($fh, $realfilename)) {
11253 0 0         local $/ = undef; # slurp mode
11254             my $script = <$fh>;
11255 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11256 0            
11257             if ($script =~ /^ (?>\s*) use (?>\s+) GBK (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11258 0           return qq[BEGIN { Egbk::require '$expr'; $module->unimport($list) if $module->can('unimport'); }];
11259             }
11260             last;
11261             }
11262 0           }
11263              
11264             return qq;
11265             }
11266              
11267             #
11268             # file path of module
11269 0     0     #
11270             sub _pathof {
11271 0 0         my($expr) = @_;
11272 0            
11273             if ($^O eq 'MacOS') {
11274             $expr =~ s#::#:#g;
11275 0           }
11276             else {
11277 0 0         $expr =~ s#::#/#g;
11278             }
11279 0           $expr .= '.pm' if $expr !~ / \.pm \z/oxmsi;
11280              
11281             return $expr;
11282             }
11283              
11284             #
11285             # real file name of module
11286 0     0     #
11287             sub _realfilename {
11288 0 0         my($expr) = @_;
11289 0            
  0            
11290             if ($^O eq 'MacOS') {
11291             return map {"$_$expr"} @INC;
11292 0           }
  0            
11293             else {
11294             return map {"$_/$expr"} @INC;
11295             }
11296             }
11297              
11298             #
11299             # instead of Carp::carp
11300 0     0 0   #
11301 0           sub carp {
11302             my($package,$filename,$line) = caller(1);
11303             print STDERR "@_ at $filename line $line.\n";
11304             }
11305              
11306             #
11307             # instead of Carp::croak
11308 0     0 0   #
11309 0           sub croak {
11310 0           my($package,$filename,$line) = caller(1);
11311             print STDERR "@_ at $filename line $line.\n";
11312             die "\n";
11313             }
11314              
11315             #
11316             # instead of Carp::cluck
11317 0     0 0   #
11318 0           sub cluck {
11319 0           my $i = 0;
11320 0           my @cluck = ();
11321 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11322             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
11323 0           $i++;
11324 0           }
11325 0           print STDERR CORE::reverse @cluck;
11326             print STDERR "\n";
11327             print STDERR @_;
11328             }
11329              
11330             #
11331             # instead of Carp::confess
11332 0     0 0   #
11333 0           sub confess {
11334 0           my $i = 0;
11335 0           my @confess = ();
11336 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11337             push @confess, "[$i] $filename($line) $package::$subroutine\n";
11338 0           $i++;
11339 0           }
11340 0           print STDERR CORE::reverse @confess;
11341 0           print STDERR "\n";
11342             print STDERR @_;
11343             die "\n";
11344             }
11345              
11346             1;
11347              
11348             __END__