File Coverage

blib/lib/Egb18030.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 Egb18030;
2 389     389   14477 use strict;
  389         4685  
  389         23230  
3             ######################################################################
4             #
5             # Egb18030 - Run-time routines for GB18030.pm
6             #
7             # http://search.cpan.org/dist/Char-GB18030/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 389     389   7913 use 5.00503; # Galapagos Consensus 1998 for primetools
  389         3222  
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   3608 use vars qw($VERSION);
  389         2618  
  389         75020  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 389 50   389   11669 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 389         1050 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 389         68058 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   35943 CORE::eval q{
  389     389   6778  
  389     134   2290  
  389         67407  
  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       201232 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       3020 if (ref $name) {
    50          
    50          
    50          
    50          
    50          
    50          
80 1152         4941 return $name;
81             }
82             elsif (Egb18030::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Egb18030::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         9597 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 50   1152 0 0 if (defined $_[1]) {
117 389     389   6174 no strict qw(refs);
  389         698  
  389         39872  
118 1152         4053 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 389     389   3740 no strict qw(refs);
  389     0   3357  
  389         91131  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  1152         1827  
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][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF]|[\x00-\xFF]};
153 389     389   3954 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  389         2044  
  389         32446  
154 389     389   4232 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  389         1004  
  389         774772  
155              
156             #
157             # GB18030 character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # GB18030 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 Egb18030 \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             4 => [ [0x81..0xFE],[0x30..0x39],[0x81..0xFE],[0x30..0x39],
186             ],
187             );
188             }
189              
190             else {
191             croak "Don't know my package name '@{[__PACKAGE__]}'";
192             }
193              
194             #
195             # @ARGV wildcard globbing
196             #
197             sub import {
198              
199 1152 50   5   6072 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
200 5         90 my @argv = ();
201 0         0 for (@ARGV) {
202              
203             # has space
204 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
205 0 0       0 if (my @glob = Egb18030::glob(qq{"$_"})) {
206 0         0 push @argv, @glob;
207             }
208             else {
209 0         0 push @argv, $_;
210             }
211             }
212              
213             # has wildcard metachar
214             elsif (/\A (?:$q_char)*? [*?] /oxms) {
215 0 0       0 if (my @glob = Egb18030::glob($_)) {
216 0         0 push @argv, @glob;
217             }
218             else {
219 0         0 push @argv, $_;
220             }
221             }
222              
223             # no wildcard globbing
224             else {
225 0         0 push @argv, $_;
226             }
227             }
228 0         0 @ARGV = @argv;
229             }
230              
231 0         0 *Char::ord = \&GB18030::ord;
232 5         28 *Char::ord_ = \&GB18030::ord_;
233 5         15 *Char::reverse = \&GB18030::reverse;
234 5         12 *Char::getc = \&GB18030::getc;
235 5         10 *Char::length = \&GB18030::length;
236 5         10 *Char::substr = \&GB18030::substr;
237 5         9 *Char::index = \&GB18030::index;
238 5         10 *Char::rindex = \&GB18030::rindex;
239 5         149 *Char::eval = \&GB18030::eval;
240 5         38 *Char::escape = \&GB18030::escape;
241 5         13 *Char::escape_token = \&GB18030::escape_token;
242 5         101 *Char::escape_script = \&GB18030::escape_script;
243             }
244              
245             # P.230 Care with Prototypes
246             # in Chapter 6: Subroutines
247             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
248             #
249             # If you aren't careful, you can get yourself into trouble with prototypes.
250             # But if you are careful, you can do a lot of neat things with them. This is
251             # all very powerful, of course, and should only be used in moderation to make
252             # the world a better place.
253              
254             # P.332 Care with Prototypes
255             # in Chapter 7: Subroutines
256             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
257             #
258             # If you aren't careful, you can get yourself into trouble with prototypes.
259             # But if you are careful, you can do a lot of neat things with them. This is
260             # all very powerful, of course, and should only be used in moderation to make
261             # the world a better place.
262              
263             #
264             # Prototypes of subroutines
265             #
266       0     sub unimport {}
267             sub Egb18030::split(;$$$);
268             sub Egb18030::tr($$$$;$);
269             sub Egb18030::chop(@);
270             sub Egb18030::index($$;$);
271             sub Egb18030::rindex($$;$);
272             sub Egb18030::lcfirst(@);
273             sub Egb18030::lcfirst_();
274             sub Egb18030::lc(@);
275             sub Egb18030::lc_();
276             sub Egb18030::ucfirst(@);
277             sub Egb18030::ucfirst_();
278             sub Egb18030::uc(@);
279             sub Egb18030::uc_();
280             sub Egb18030::fc(@);
281             sub Egb18030::fc_();
282             sub Egb18030::ignorecase;
283             sub Egb18030::classic_character_class;
284             sub Egb18030::capture;
285             sub Egb18030::chr(;$);
286             sub Egb18030::chr_();
287             sub Egb18030::filetest;
288             sub Egb18030::r(;*@);
289             sub Egb18030::w(;*@);
290             sub Egb18030::x(;*@);
291             sub Egb18030::o(;*@);
292             sub Egb18030::R(;*@);
293             sub Egb18030::W(;*@);
294             sub Egb18030::X(;*@);
295             sub Egb18030::O(;*@);
296             sub Egb18030::e(;*@);
297             sub Egb18030::z(;*@);
298             sub Egb18030::s(;*@);
299             sub Egb18030::f(;*@);
300             sub Egb18030::d(;*@);
301             sub Egb18030::l(;*@);
302             sub Egb18030::p(;*@);
303             sub Egb18030::S(;*@);
304             sub Egb18030::b(;*@);
305             sub Egb18030::c(;*@);
306             sub Egb18030::u(;*@);
307             sub Egb18030::g(;*@);
308             sub Egb18030::k(;*@);
309             sub Egb18030::T(;*@);
310             sub Egb18030::B(;*@);
311             sub Egb18030::M(;*@);
312             sub Egb18030::A(;*@);
313             sub Egb18030::C(;*@);
314             sub Egb18030::filetest_;
315             sub Egb18030::r_();
316             sub Egb18030::w_();
317             sub Egb18030::x_();
318             sub Egb18030::o_();
319             sub Egb18030::R_();
320             sub Egb18030::W_();
321             sub Egb18030::X_();
322             sub Egb18030::O_();
323             sub Egb18030::e_();
324             sub Egb18030::z_();
325             sub Egb18030::s_();
326             sub Egb18030::f_();
327             sub Egb18030::d_();
328             sub Egb18030::l_();
329             sub Egb18030::p_();
330             sub Egb18030::S_();
331             sub Egb18030::b_();
332             sub Egb18030::c_();
333             sub Egb18030::u_();
334             sub Egb18030::g_();
335             sub Egb18030::k_();
336             sub Egb18030::T_();
337             sub Egb18030::B_();
338             sub Egb18030::M_();
339             sub Egb18030::A_();
340             sub Egb18030::C_();
341             sub Egb18030::glob($);
342             sub Egb18030::glob_();
343             sub Egb18030::lstat(*);
344             sub Egb18030::lstat_();
345             sub Egb18030::opendir(*$);
346             sub Egb18030::stat(*);
347             sub Egb18030::stat_();
348             sub Egb18030::unlink(@);
349             sub Egb18030::chdir(;$);
350             sub Egb18030::do($);
351             sub Egb18030::require(;$);
352             sub Egb18030::telldir(*);
353              
354             sub GB18030::ord(;$);
355             sub GB18030::ord_();
356             sub GB18030::reverse(@);
357             sub GB18030::getc(;*@);
358             sub GB18030::length(;$);
359             sub GB18030::substr($$;$$);
360             sub GB18030::index($$;$);
361             sub GB18030::rindex($$;$);
362             sub GB18030::escape(;$);
363              
364             #
365             # Regexp work
366             #
367 389         44581 use vars qw(
368             $re_a
369             $re_t
370             $re_n
371             $re_r
372 389     389   5636 );
  389         3483  
373              
374             #
375             # Character class
376             #
377 389         133861 use vars qw(
378             $dot
379             $dot_s
380             $eD
381             $eS
382             $eW
383             $eH
384             $eV
385             $eR
386             $eN
387             $not_alnum
388             $not_alpha
389             $not_ascii
390             $not_blank
391             $not_cntrl
392             $not_digit
393             $not_graph
394             $not_lower
395             $not_lower_i
396             $not_print
397             $not_punct
398             $not_space
399             $not_upper
400             $not_upper_i
401             $not_word
402             $not_xdigit
403             $eb
404             $eB
405 389     389   5343 );
  389         643  
406              
407 389         5482834 use vars qw(
408             $anchor
409             $matched
410 389     389   2440 );
  389         2391  
411             ${Egb18030::anchor} = qr{\G(?>[^\x81-\xFE]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])*?}oxms;
412              
413             # unless LONG_STRING_FOR_RE
414             if (1) {
415             }
416              
417             my $q_char_SADAHIRO_Tomoyuki_2002_01_17 = '';
418              
419             # Quantifiers
420             # {n,m} --- Match at least n but not more than m times
421             #
422             # n and m are limited to non-negative integral values less than a
423             # preset limit defined when perl is built. This is usually 32766 on
424             # the most common platforms.
425             #
426             # The following code is an attempt to solve the above limitations
427             # in a multi-byte anchoring.
428              
429             # avoid "Segmentation fault" and "Error: Parse exception"
430              
431             # perl5101delta
432             # http://perldoc.perl.org/perl5101delta.html
433             # In 5.10.0, the * quantifier in patterns was sometimes treated as {0,32767}
434             # [RT #60034, #60464]. For example, this match would fail:
435             # ("ab" x 32768) =~ /^(ab)*$/
436              
437             # SEE ALSO
438             #
439             # Complex regular subexpression recursion limit
440             # http://www.perlmonks.org/?node_id=810857
441             #
442             # regexp iteration limits
443             # http://www.nntp.perl.org/group/perl.perl5.porters/2009/02/msg144065.html
444             #
445             # latest Perl won't match certain regexes more than 32768 characters long
446             # http://stackoverflow.com/questions/26226630/latest-perl-wont-match-certain-regexes-more-than-32768-characters-long
447             #
448             # Break through the limitations of regular expressions of Perl
449             # http://d.hatena.ne.jp/gfx/20110212/1297512479
450              
451             if (($] >= 5.010001) or
452             # ActivePerl 5.6 or later (include 5.10.0)
453             (defined($ActivePerl::VERSION) and ($ActivePerl::VERSION > 800)) or
454             (($^O eq 'MSWin32') and ($] =~ /\A 5\.006/oxms))
455             ) {
456             my $sbcs = ''; # Single Byte Character Set
457             for my $range (@{ $range_tr{1} }) {
458             $sbcs .= sprintf('\\x%02X-\\x%02X', $range->[0], $range->[-1]);
459             }
460              
461             if (0) {
462             }
463              
464             # GB18030 encoding
465             elsif (__PACKAGE__ =~ / \b Egb18030 \z/oxms) {
466             ${Egb18030::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[^\x30-\x39\x81-\xFE](?>[\x30-\x39]|[\x81-\xFE][\x81-\xFE]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x30-\x39])*?}oxms;
467             # ********************* octets not in multiple octet char (always char boundary)
468             # *********** 1 octet chars in multiple octet char
469             # ********************** 2 octet chars
470             # ******************************************** 4 octet chars
471             }
472              
473             # other encoding
474             else {
475             ${Egb18030::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[$sbcs](?:[^$sbcs][^$sbcs])*?}oxms;
476             # ******* octets not in multiple octet char (always char boundary)
477             # **************** 2 octet chars
478             }
479              
480             ${Egb18030::anchor_SADAHIRO_Tomoyuki_2002_01_17} =
481             qr{\G(?(?=.{0,32766}\z)(?:[^\x81-\xFE]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])*?|(?(?=[$sbcs]+\z).*?|(?:${Egb18030::q_char_SADAHIRO_Tomoyuki_2002_01_17})))}oxms;
482             # qr{
483             # \G # (1), (2)
484             # (? # (3)
485             # (?=.{0,32766}\z) # (4)
486             # (?:[^\x81-\xFE]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])*?| # (5)
487             # (?(?=[$sbcs]+\z) # (6)
488             # .*?| #(7)
489             # (?:${Egb18030::q_char_SADAHIRO_Tomoyuki_2002_01_17}) # (8)
490             # ))}oxms;
491              
492             # avoid: Complex regular subexpression recursion limit (32766) exceeded at here.
493             local $^W = 0;
494              
495             if (((('A' x 32768).'B') !~ / ${Egb18030::anchor} B /oxms) and
496             ((('A' x 32768).'B') =~ / ${Egb18030::anchor_SADAHIRO_Tomoyuki_2002_01_17} B /oxms)
497             ) {
498             ${Egb18030::anchor} = ${Egb18030::anchor_SADAHIRO_Tomoyuki_2002_01_17};
499             }
500             else {
501             undef ${Egb18030::q_char_SADAHIRO_Tomoyuki_2002_01_17};
502             }
503             }
504              
505             # (1)
506             # P.128 Start of match (or end of previous match): \G
507             # P.130 Advanced Use of \G with Perl
508             # in Chapter3: Over view of Regular Expression Features and Flavors
509             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
510              
511             # (2)
512             # P.255 Use leading anchors
513             # P.256 Expose ^ and \G at the front of expressions
514             # in Chapter6: Crafting an Efficient Expression
515             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
516              
517             # (3)
518             # P.138 Conditional: (? if then| else)
519             # in Chapter3: Over view of Regular Expression Features and Flavors
520             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
521              
522             # (4)
523             # perlre
524             # http://perldoc.perl.org/perlre.html
525             # The "*" quantifier is equivalent to {0,} , the "+" quantifier to {1,} ,
526             # and the "?" quantifier to {0,1}, ., n, and m are limited to non-negative
527             # integral values less than a preset limit defined when perl is built.
528             # This is usually 32766 on the most common platforms. The actual limit
529             # can be seen in the error message generated by code such as this:
530             # $_ **= $_ , / {$_} / for 2 .. 42;
531              
532             # (5)
533             # P.1023 Multiple-Byte Anchoring
534             # in Appendix W Perl Code Examples
535             # of ISBN 1-56592-224-7 CJKV Information Processing
536              
537             # (6)
538             # if string has only SBCS (Single Byte Character Set)
539              
540             # (7)
541             # then .*? (isn't limited to 32766)
542              
543             # (8)
544             # else GB18030::Regexp::Const (SADAHIRO Tomoyuki)
545             # http://homepage1.nifty.com/nomenclator/perl/shiftjis.htm#long
546             # http://search.cpan.org/~sadahiro/GB18030-Regexp/
547             # $PadA = ' (?:\A| [\x00-\x80\xA0-\xDF])(?:[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE]{2})*?';
548             # $PadG = '\G(?: |[\x00-\xFF]*?[\x00-\x80\xA0-\xDF])(?:[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE]{2})*?';
549             # $PadGA = '\G(?:\A|(?:[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE]{2})+?|[\x00-\xFF]*?[\x00-\x80\xA0-\xDF] (?:[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE]{2})*?)';
550              
551             ${Egb18030::dot} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
552             ${Egb18030::dot_s} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
553             ${Egb18030::eD} = qr{(?>[^\x81-\xFE0-9]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
554              
555             # Vertical tabs are now whitespace
556             # \s in a regex now matches a vertical tab in all circumstances.
557             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
558             # ${Egb18030::eS} = qr{(?>[^\x81-\xFE\x09\x0A \x0C\x0D\x20]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
559             # ${Egb18030::eS} = qr{(?>[^\x81-\xFE\x09\x0A\x0B\x0C\x0D\x20]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
560             ${Egb18030::eS} = qr{(?>[^\x81-\xFE\s]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
561              
562             ${Egb18030::eW} = qr{(?>[^\x81-\xFE0-9A-Z_a-z]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
563             ${Egb18030::eH} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
564             ${Egb18030::eV} = qr{(?>[^\x81-\xFE\x0A\x0B\x0C\x0D]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
565             ${Egb18030::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
566             ${Egb18030::eN} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
567             ${Egb18030::not_alnum} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x61-\x7A]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
568             ${Egb18030::not_alpha} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
569             ${Egb18030::not_ascii} = qr{(?>[^\x81-\xFE\x00-\x7F]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
570             ${Egb18030::not_blank} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
571             ${Egb18030::not_cntrl} = qr{(?>[^\x81-\xFE\x00-\x1F\x7F]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
572             ${Egb18030::not_digit} = qr{(?>[^\x81-\xFE\x30-\x39]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
573             ${Egb18030::not_graph} = qr{(?>[^\x81-\xFE\x21-\x7F]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
574             ${Egb18030::not_lower} = qr{(?>[^\x81-\xFE\x61-\x7A]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
575             ${Egb18030::not_lower_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
576             # ${Egb18030::not_lower_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])}; # older Perl compatible
577             ${Egb18030::not_print} = qr{(?>[^\x81-\xFE\x20-\x7F]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
578             ${Egb18030::not_punct} = qr{(?>[^\x81-\xFE\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
579             ${Egb18030::not_space} = qr{(?>[^\x81-\xFE\s\x0B]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
580             ${Egb18030::not_upper} = qr{(?>[^\x81-\xFE\x41-\x5A]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
581             ${Egb18030::not_upper_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
582             # ${Egb18030::not_upper_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])}; # older Perl compatible
583             ${Egb18030::not_word} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x5F\x61-\x7A]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
584             ${Egb18030::not_xdigit} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x46\x61-\x66]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])};
585             ${Egb18030::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))};
586             ${Egb18030::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]))};
587              
588             # avoid: Name "Egb18030::foo" used only once: possible typo at here.
589             ${Egb18030::dot} = ${Egb18030::dot};
590             ${Egb18030::dot_s} = ${Egb18030::dot_s};
591             ${Egb18030::eD} = ${Egb18030::eD};
592             ${Egb18030::eS} = ${Egb18030::eS};
593             ${Egb18030::eW} = ${Egb18030::eW};
594             ${Egb18030::eH} = ${Egb18030::eH};
595             ${Egb18030::eV} = ${Egb18030::eV};
596             ${Egb18030::eR} = ${Egb18030::eR};
597             ${Egb18030::eN} = ${Egb18030::eN};
598             ${Egb18030::not_alnum} = ${Egb18030::not_alnum};
599             ${Egb18030::not_alpha} = ${Egb18030::not_alpha};
600             ${Egb18030::not_ascii} = ${Egb18030::not_ascii};
601             ${Egb18030::not_blank} = ${Egb18030::not_blank};
602             ${Egb18030::not_cntrl} = ${Egb18030::not_cntrl};
603             ${Egb18030::not_digit} = ${Egb18030::not_digit};
604             ${Egb18030::not_graph} = ${Egb18030::not_graph};
605             ${Egb18030::not_lower} = ${Egb18030::not_lower};
606             ${Egb18030::not_lower_i} = ${Egb18030::not_lower_i};
607             ${Egb18030::not_print} = ${Egb18030::not_print};
608             ${Egb18030::not_punct} = ${Egb18030::not_punct};
609             ${Egb18030::not_space} = ${Egb18030::not_space};
610             ${Egb18030::not_upper} = ${Egb18030::not_upper};
611             ${Egb18030::not_upper_i} = ${Egb18030::not_upper_i};
612             ${Egb18030::not_word} = ${Egb18030::not_word};
613             ${Egb18030::not_xdigit} = ${Egb18030::not_xdigit};
614             ${Egb18030::eb} = ${Egb18030::eb};
615             ${Egb18030::eB} = ${Egb18030::eB};
616              
617             #
618             # GB18030 split
619             #
620             sub Egb18030::split(;$$$) {
621              
622             # P.794 29.2.161. split
623             # in Chapter 29: Functions
624             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
625              
626             # P.951 split
627             # in Chapter 27: Functions
628             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
629              
630 5     0 0 14745 my $pattern = $_[0];
631 0         0 my $string = $_[1];
632 0         0 my $limit = $_[2];
633              
634             # if $pattern is also omitted or is the literal space, " "
635 0 0       0 if (not defined $pattern) {
636 0         0 $pattern = ' ';
637             }
638              
639             # if $string is omitted, the function splits the $_ string
640 0 0       0 if (not defined $string) {
641 0 0       0 if (defined $_) {
642 0         0 $string = $_;
643             }
644             else {
645 0         0 $string = '';
646             }
647             }
648              
649 0         0 my @split = ();
650              
651             # when string is empty
652 0 0       0 if ($string eq '') {
    0          
653              
654             # resulting list value in list context
655 0 0       0 if (wantarray) {
656 0         0 return @split;
657             }
658              
659             # count of substrings in scalar context
660             else {
661 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
662 0         0 @_ = @split;
663 0         0 return scalar @_;
664             }
665             }
666              
667             # split's first argument is more consistently interpreted
668             #
669             # After some changes earlier in v5.17, split's behavior has been simplified:
670             # if the PATTERN argument evaluates to a string containing one space, it is
671             # treated the way that a literal string containing one space once was.
672             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
673              
674             # if $pattern is also omitted or is the literal space, " ", the function splits
675             # on whitespace, /\s+/, after skipping any leading whitespace
676             # (and so on)
677              
678             elsif ($pattern eq ' ') {
679 0 0       0 if (not defined $limit) {
680 0         0 return CORE::split(' ', $string);
681             }
682             else {
683 0         0 return CORE::split(' ', $string, $limit);
684             }
685             }
686              
687 0         0 local $q_char = $q_char;
688 0 0       0 if (CORE::length($string) > 32766) {
689 0 0       0 if ($string =~ /\A [\x00-\x7F]+ \z/oxms) {
    0          
690 0         0 $q_char = qr{.}s;
691             }
692             elsif (defined ${Egb18030::q_char_SADAHIRO_Tomoyuki_2002_01_17}) {
693 0         0 $q_char = ${Egb18030::q_char_SADAHIRO_Tomoyuki_2002_01_17};
694             }
695             }
696              
697             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
698 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
699              
700             # a pattern capable of matching either the null string or something longer than the
701             # null string will split the value of $string into separate characters wherever it
702             # matches the null string between characters
703             # (and so on)
704              
705 0 0       0 if ('' =~ / \A $pattern \z /xms) {
706 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
707 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
708              
709             # P.1024 Appendix W.10 Multibyte Processing
710             # of ISBN 1-56592-224-7 CJKV Information Processing
711             # (and so on)
712              
713             # the //m modifier is assumed when you split on the pattern /^/
714             # (and so on)
715              
716             # V
717 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
718              
719             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
720             # is included in the resulting list, interspersed with the fields that are ordinarily returned
721             # (and so on)
722              
723 0         0 local $@;
724 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
725 0         0 push @split, CORE::eval('$' . $digit);
726             }
727             }
728             }
729              
730             else {
731 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
732              
733             # V
734 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
735 0         0 local $@;
736 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
737 0         0 push @split, CORE::eval('$' . $digit);
738             }
739             }
740             }
741             }
742              
743             elsif ($limit > 0) {
744 0 0       0 if ('' =~ / \A $pattern \z /xms) {
745 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
746 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
747              
748             # V
749 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
750 0         0 local $@;
751 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
752 0         0 push @split, CORE::eval('$' . $digit);
753             }
754             }
755             }
756             }
757             else {
758 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
759 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
760              
761             # V
762 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
763 0         0 local $@;
764 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
765 0         0 push @split, CORE::eval('$' . $digit);
766             }
767             }
768             }
769             }
770             }
771              
772 0 0       0 if (CORE::length($string) > 0) {
773 0         0 push @split, $string;
774             }
775              
776             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
777 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
778 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
779 0         0 pop @split;
780             }
781             }
782              
783             # resulting list value in list context
784 0 0       0 if (wantarray) {
785 0         0 return @split;
786             }
787              
788             # count of substrings in scalar context
789             else {
790 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
791 0         0 @_ = @split;
792 0         0 return scalar @_;
793             }
794             }
795              
796             #
797             # get last subexpression offsets
798             #
799             sub _last_subexpression_offsets {
800 0     0   0 my $pattern = $_[0];
801              
802             # remove comment
803 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
804              
805 0         0 my $modifier = '';
806 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
807 0         0 $modifier = $1;
808 0         0 $modifier =~ s/-[A-Za-z]*//;
809             }
810              
811             # with /x modifier
812 0         0 my @char = ();
813 0 0       0 if ($modifier =~ /x/oxms) {
814 0         0 @char = $pattern =~ /\G((?>
815             [^\x81-\xFE\\\#\[\(]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
816             \\ $q_char |
817             \# (?>[^\n]*) $ |
818             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
819             \(\? |
820             $q_char
821             ))/oxmsg;
822             }
823              
824             # without /x modifier
825             else {
826 0         0 @char = $pattern =~ /\G((?>
827             [^\x81-\xFE\\\[\(]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
828             \\ $q_char |
829             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
830             \(\? |
831             $q_char
832             ))/oxmsg;
833             }
834              
835 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
836             }
837              
838             #
839             # GB18030 transliteration (tr///)
840             #
841             sub Egb18030::tr($$$$;$) {
842              
843 0     0 0 0 my $bind_operator = $_[1];
844 0         0 my $searchlist = $_[2];
845 0         0 my $replacementlist = $_[3];
846 0   0     0 my $modifier = $_[4] || '';
847              
848 0 0       0 if ($modifier =~ /r/oxms) {
849 0 0       0 if ($bind_operator =~ / !~ /oxms) {
850 0         0 croak "Using !~ with tr///r doesn't make sense";
851             }
852             }
853              
854 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
855 0         0 my @searchlist = _charlist_tr($searchlist);
856 0         0 my @replacementlist = _charlist_tr($replacementlist);
857              
858 0         0 my %tr = ();
859 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
860 0 0       0 if (not exists $tr{$searchlist[$i]}) {
861 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
862 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
863             }
864             elsif ($modifier =~ /d/oxms) {
865 0         0 $tr{$searchlist[$i]} = '';
866             }
867             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
868 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
869             }
870             else {
871 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
872             }
873             }
874             }
875              
876 0         0 my $tr = 0;
877 0         0 my $replaced = '';
878 0 0       0 if ($modifier =~ /c/oxms) {
879 0         0 while (defined(my $char = shift @char)) {
880 0 0       0 if (not exists $tr{$char}) {
881 0 0       0 if (defined $replacementlist[0]) {
882 0         0 $replaced .= $replacementlist[0];
883             }
884 0         0 $tr++;
885 0 0       0 if ($modifier =~ /s/oxms) {
886 0   0     0 while (@char and (not exists $tr{$char[0]})) {
887 0         0 shift @char;
888 0         0 $tr++;
889             }
890             }
891             }
892             else {
893 0         0 $replaced .= $char;
894             }
895             }
896             }
897             else {
898 0         0 while (defined(my $char = shift @char)) {
899 0 0       0 if (exists $tr{$char}) {
900 0         0 $replaced .= $tr{$char};
901 0         0 $tr++;
902 0 0       0 if ($modifier =~ /s/oxms) {
903 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
904 0         0 shift @char;
905 0         0 $tr++;
906             }
907             }
908             }
909             else {
910 0         0 $replaced .= $char;
911             }
912             }
913             }
914              
915 0 0       0 if ($modifier =~ /r/oxms) {
916 0         0 return $replaced;
917             }
918             else {
919 0         0 $_[0] = $replaced;
920 0 0       0 if ($bind_operator =~ / !~ /oxms) {
921 0         0 return not $tr;
922             }
923             else {
924 0         0 return $tr;
925             }
926             }
927             }
928              
929             #
930             # GB18030 chop
931             #
932             sub Egb18030::chop(@) {
933              
934 0     0 0 0 my $chop;
935 0 0       0 if (@_ == 0) {
936 0         0 my @char = /\G (?>$q_char) /oxmsg;
937 0         0 $chop = pop @char;
938 0         0 $_ = join '', @char;
939             }
940             else {
941 0         0 for (@_) {
942 0         0 my @char = /\G (?>$q_char) /oxmsg;
943 0         0 $chop = pop @char;
944 0         0 $_ = join '', @char;
945             }
946             }
947 0         0 return $chop;
948             }
949              
950             #
951             # GB18030 index by octet
952             #
953             sub Egb18030::index($$;$) {
954              
955 0     2304 1 0 my($str,$substr,$position) = @_;
956 2304   50     5032 $position ||= 0;
957 2304         9157 my $pos = 0;
958              
959 2304         2862 while ($pos < CORE::length($str)) {
960 2304 50       6721 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
961 59292 0       115246 if ($pos >= $position) {
962 0         0 return $pos;
963             }
964             }
965 0 50       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
966 59292         148617 $pos += CORE::length($1);
967             }
968             else {
969 59292         137995 $pos += 1;
970             }
971             }
972 0         0 return -1;
973             }
974              
975             #
976             # GB18030 reverse index
977             #
978             sub Egb18030::rindex($$;$) {
979              
980 2304     0 0 16781 my($str,$substr,$position) = @_;
981 0   0     0 $position ||= CORE::length($str) - 1;
982 0         0 my $pos = 0;
983 0         0 my $rindex = -1;
984              
985 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
986 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
987 0         0 $rindex = $pos;
988             }
989 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
990 0         0 $pos += CORE::length($1);
991             }
992             else {
993 0         0 $pos += 1;
994             }
995             }
996 0         0 return $rindex;
997             }
998              
999             #
1000             # GB18030 lower case first with parameter
1001             #
1002             sub Egb18030::lcfirst(@) {
1003 0 0   0 0 0 if (@_) {
1004 0         0 my $s = shift @_;
1005 0 0 0     0 if (@_ and wantarray) {
1006 0         0 return Egb18030::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1007             }
1008             else {
1009 0         0 return Egb18030::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1010             }
1011             }
1012             else {
1013 0         0 return Egb18030::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1014             }
1015             }
1016              
1017             #
1018             # GB18030 lower case first without parameter
1019             #
1020             sub Egb18030::lcfirst_() {
1021 0     0 0 0 return Egb18030::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1022             }
1023              
1024             #
1025             # GB18030 lower case with parameter
1026             #
1027             sub Egb18030::lc(@) {
1028 0 0   0 0 0 if (@_) {
1029 0         0 my $s = shift @_;
1030 0 0 0     0 if (@_ and wantarray) {
1031 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1032             }
1033             else {
1034 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1035             }
1036             }
1037             else {
1038 0         0 return Egb18030::lc_();
1039             }
1040             }
1041              
1042             #
1043             # GB18030 lower case without parameter
1044             #
1045             sub Egb18030::lc_() {
1046 0     0 0 0 my $s = $_;
1047 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1048             }
1049              
1050             #
1051             # GB18030 upper case first with parameter
1052             #
1053             sub Egb18030::ucfirst(@) {
1054 0 0   0 0 0 if (@_) {
1055 0         0 my $s = shift @_;
1056 0 0 0     0 if (@_ and wantarray) {
1057 0         0 return Egb18030::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1058             }
1059             else {
1060 0         0 return Egb18030::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1061             }
1062             }
1063             else {
1064 0         0 return Egb18030::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1065             }
1066             }
1067              
1068             #
1069             # GB18030 upper case first without parameter
1070             #
1071             sub Egb18030::ucfirst_() {
1072 0     0 0 0 return Egb18030::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1073             }
1074              
1075             #
1076             # GB18030 upper case with parameter
1077             #
1078             sub Egb18030::uc(@) {
1079 0 50   2968 0 0 if (@_) {
1080 2968         6105 my $s = shift @_;
1081 2968 50 33     3767 if (@_ and wantarray) {
1082 2968 0       5591 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1083             }
1084             else {
1085 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  2968         10722  
1086             }
1087             }
1088             else {
1089 2968         10406 return Egb18030::uc_();
1090             }
1091             }
1092              
1093             #
1094             # GB18030 upper case without parameter
1095             #
1096             sub Egb18030::uc_() {
1097 0     0 0 0 my $s = $_;
1098 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1099             }
1100              
1101             #
1102             # GB18030 fold case with parameter
1103             #
1104             sub Egb18030::fc(@) {
1105 0 50   3271 0 0 if (@_) {
1106 3271         5239 my $s = shift @_;
1107 3271 50 33     4394 if (@_ and wantarray) {
1108 3271 0       5607 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1109             }
1110             else {
1111 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3271         8904  
1112             }
1113             }
1114             else {
1115 3271         12736 return Egb18030::fc_();
1116             }
1117             }
1118              
1119             #
1120             # GB18030 fold case without parameter
1121             #
1122             sub Egb18030::fc_() {
1123 0     0 0 0 my $s = $_;
1124 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1125             }
1126              
1127             #
1128             # GB18030 regexp capture
1129             #
1130             {
1131             # 10.3. Creating Persistent Private Variables
1132             # in Chapter 10. Subroutines
1133             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
1134              
1135             my $last_s_matched = 0;
1136              
1137             sub Egb18030::capture {
1138 0 0 0 0 1 0 if ($last_s_matched and ($_[0] =~ /\A (?>[1-9][0-9]*) \z/oxms)) {
1139 0         0 return $_[0] + 1;
1140             }
1141 0         0 return $_[0];
1142             }
1143              
1144             # GB18030 mark last regexp matched
1145             sub Egb18030::matched() {
1146 0     0 0 0 $last_s_matched = 0;
1147             }
1148              
1149             # GB18030 mark last s/// matched
1150             sub Egb18030::s_matched() {
1151 0     0 0 0 $last_s_matched = 1;
1152             }
1153              
1154             # P.854 31.17. use re
1155             # in Chapter 31. Pragmatic Modules
1156             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1157              
1158             # P.1026 re
1159             # in Chapter 29. Pragmatic Modules
1160             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1161              
1162             $Egb18030::matched = qr/(?{Egb18030::matched})/;
1163             }
1164              
1165             #
1166             # GB18030 regexp ignore case modifier
1167             #
1168             sub Egb18030::ignorecase {
1169              
1170 0     0 0 0 my @string = @_;
1171 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1172              
1173             # ignore case of $scalar or @array
1174 0         0 for my $string (@string) {
1175              
1176             # split regexp
1177 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1178              
1179             # unescape character
1180 0         0 for (my $i=0; $i <= $#char; $i++) {
1181 0 0       0 next if not defined $char[$i];
1182              
1183             # open character class [...]
1184 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1185 0         0 my $left = $i;
1186              
1187             # [] make die "unmatched [] in regexp ...\n"
1188              
1189 0 0       0 if ($char[$i+1] eq ']') {
1190 0         0 $i++;
1191             }
1192              
1193 0         0 while (1) {
1194 0 0       0 if (++$i > $#char) {
1195 0         0 croak "Unmatched [] in regexp";
1196             }
1197 0 0       0 if ($char[$i] eq ']') {
1198 0         0 my $right = $i;
1199 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1200              
1201             # escape character
1202 0         0 for my $char (@charlist) {
1203 0 0       0 if (0) {
    0          
1204             }
1205              
1206             # do not use quotemeta here
1207 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1208 0         0 $char = $1 . '\\' . $2;
1209             }
1210             elsif ($char =~ /\A [.|)] \z/oxms) {
1211 0         0 $char = '\\' . $char;
1212             }
1213             }
1214              
1215             # [...]
1216 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1217              
1218 0         0 $i = $left;
1219 0         0 last;
1220             }
1221             }
1222             }
1223              
1224             # open character class [^...]
1225             elsif ($char[$i] eq '[^') {
1226 0         0 my $left = $i;
1227              
1228             # [^] make die "unmatched [] in regexp ...\n"
1229              
1230 0 0       0 if ($char[$i+1] eq ']') {
1231 0         0 $i++;
1232             }
1233              
1234 0         0 while (1) {
1235 0 0       0 if (++$i > $#char) {
1236 0         0 croak "Unmatched [] in regexp";
1237             }
1238 0 0       0 if ($char[$i] eq ']') {
1239 0         0 my $right = $i;
1240 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1241              
1242             # escape character
1243 0         0 for my $char (@charlist) {
1244 0 0       0 if (0) {
    0          
1245             }
1246              
1247             # do not use quotemeta here
1248 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1249 0         0 $char = $1 . '\\' . $2;
1250             }
1251             elsif ($char =~ /\A [.|)] \z/oxms) {
1252 0         0 $char = '\\' . $char;
1253             }
1254             }
1255              
1256             # [^...]
1257 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1258              
1259 0         0 $i = $left;
1260 0         0 last;
1261             }
1262             }
1263             }
1264              
1265             # rewrite classic character class or escape character
1266             elsif (my $char = classic_character_class($char[$i])) {
1267 0         0 $char[$i] = $char;
1268             }
1269              
1270             # with /i modifier
1271             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1272 0         0 my $uc = Egb18030::uc($char[$i]);
1273 0         0 my $fc = Egb18030::fc($char[$i]);
1274 0 0       0 if ($uc ne $fc) {
1275 0 0       0 if (CORE::length($fc) == 1) {
1276 0         0 $char[$i] = '[' . $uc . $fc . ']';
1277             }
1278             else {
1279 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1280             }
1281             }
1282             }
1283             }
1284              
1285             # characterize
1286 0         0 for (my $i=0; $i <= $#char; $i++) {
1287 0 0       0 next if not defined $char[$i];
1288              
1289 0 0 0     0 if (0) {
    0          
1290             }
1291              
1292             # escape last octet of multiple-octet
1293 0         0 elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1294 0         0 $char[$i] = $1 . '\\' . $2;
1295             }
1296              
1297             # quote character before ? + * {
1298             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1299 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1300 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1301             }
1302             }
1303             }
1304              
1305 0         0 $string = join '', @char;
1306             }
1307              
1308             # make regexp string
1309 0         0 return @string;
1310             }
1311              
1312             #
1313             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1314             #
1315             sub Egb18030::classic_character_class {
1316 0     5379 0 0 my($char) = @_;
1317              
1318             return {
1319             '\D' => '${Egb18030::eD}',
1320             '\S' => '${Egb18030::eS}',
1321             '\W' => '${Egb18030::eW}',
1322             '\d' => '[0-9]',
1323              
1324             # Before Perl 5.6, \s only matched the five whitespace characters
1325             # tab, newline, form-feed, carriage return, and the space character
1326             # itself, which, taken together, is the character class [\t\n\f\r ].
1327              
1328             # Vertical tabs are now whitespace
1329             # \s in a regex now matches a vertical tab in all circumstances.
1330             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1331             # \t \n \v \f \r space
1332             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1333             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1334             '\s' => '\s',
1335              
1336             '\w' => '[0-9A-Z_a-z]',
1337             '\C' => '[\x00-\xFF]',
1338             '\X' => 'X',
1339              
1340             # \h \v \H \V
1341              
1342             # P.114 Character Class Shortcuts
1343             # in Chapter 7: In the World of Regular Expressions
1344             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1345              
1346             # P.357 13.2.3 Whitespace
1347             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1348             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1349             #
1350             # 0x00009 CHARACTER TABULATION h s
1351             # 0x0000a LINE FEED (LF) vs
1352             # 0x0000b LINE TABULATION v
1353             # 0x0000c FORM FEED (FF) vs
1354             # 0x0000d CARRIAGE RETURN (CR) vs
1355             # 0x00020 SPACE h s
1356              
1357             # P.196 Table 5-9. Alphanumeric regex metasymbols
1358             # in Chapter 5. Pattern Matching
1359             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1360              
1361             # (and so on)
1362              
1363             '\H' => '${Egb18030::eH}',
1364             '\V' => '${Egb18030::eV}',
1365             '\h' => '[\x09\x20]',
1366             '\v' => '[\x0A\x0B\x0C\x0D]',
1367             '\R' => '${Egb18030::eR}',
1368              
1369             # \N
1370             #
1371             # http://perldoc.perl.org/perlre.html
1372             # Character Classes and other Special Escapes
1373             # Any character but \n (experimental). Not affected by /s modifier
1374              
1375             '\N' => '${Egb18030::eN}',
1376              
1377             # \b \B
1378              
1379             # P.180 Boundaries: The \b and \B Assertions
1380             # in Chapter 5: Pattern Matching
1381             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1382              
1383             # P.219 Boundaries: The \b and \B Assertions
1384             # in Chapter 5: Pattern Matching
1385             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1386              
1387             # \b really means (?:(?<=\w)(?!\w)|(?
1388             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1389             '\b' => '${Egb18030::eb}',
1390              
1391             # \B really means (?:(?<=\w)(?=\w)|(?
1392             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1393             '\B' => '${Egb18030::eB}',
1394              
1395 5379   100     7506 }->{$char} || '';
1396             }
1397              
1398             #
1399             # prepare GB18030 characters per length
1400             #
1401              
1402             # 1 octet characters
1403             my @chars1 = ();
1404             sub chars1 {
1405 5379 0   0 0 206640 if (@chars1) {
1406 0         0 return @chars1;
1407             }
1408 0 0       0 if (exists $range_tr{1}) {
1409 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1410 0         0 while (my @range = splice(@ranges,0,1)) {
1411 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1412 0         0 push @chars1, pack 'C', $oct0;
1413             }
1414             }
1415             }
1416 0         0 return @chars1;
1417             }
1418              
1419             # 2 octets characters
1420             my @chars2 = ();
1421             sub chars2 {
1422 0 0   0 0 0 if (@chars2) {
1423 0         0 return @chars2;
1424             }
1425 0 0       0 if (exists $range_tr{2}) {
1426 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1427 0         0 while (my @range = splice(@ranges,0,2)) {
1428 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1429 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1430 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1431             }
1432             }
1433             }
1434             }
1435 0         0 return @chars2;
1436             }
1437              
1438             # 3 octets characters
1439             my @chars3 = ();
1440             sub chars3 {
1441 0 0   0 0 0 if (@chars3) {
1442 0         0 return @chars3;
1443             }
1444 0 0       0 if (exists $range_tr{3}) {
1445 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1446 0         0 while (my @range = splice(@ranges,0,3)) {
1447 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1448 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1449 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1450 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1451             }
1452             }
1453             }
1454             }
1455             }
1456 0         0 return @chars3;
1457             }
1458              
1459             # 4 octets characters
1460             my @chars4 = ();
1461             sub chars4 {
1462 0 0   0 0 0 if (@chars4) {
1463 0         0 return @chars4;
1464             }
1465 0 0       0 if (exists $range_tr{4}) {
1466 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1467 0         0 while (my @range = splice(@ranges,0,4)) {
1468 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1469 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1470 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1471 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1472 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1473             }
1474             }
1475             }
1476             }
1477             }
1478             }
1479 0         0 return @chars4;
1480             }
1481              
1482             #
1483             # GB18030 open character list for tr
1484             #
1485             sub _charlist_tr {
1486              
1487 0     0   0 local $_ = shift @_;
1488              
1489             # unescape character
1490 0         0 my @char = ();
1491 0         0 while (not /\G \z/oxmsgc) {
1492 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1493 0         0 push @char, '\-';
1494             }
1495             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1496 0         0 push @char, CORE::chr(oct $1);
1497             }
1498             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1499 0         0 push @char, CORE::chr(hex $1);
1500             }
1501             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1502 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1503             }
1504             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1505             push @char, {
1506             '\0' => "\0",
1507             '\n' => "\n",
1508             '\r' => "\r",
1509             '\t' => "\t",
1510             '\f' => "\f",
1511             '\b' => "\x08", # \b means backspace in character class
1512             '\a' => "\a",
1513             '\e' => "\e",
1514 0         0 }->{$1};
1515             }
1516             elsif (/\G \\ ($q_char) /oxmsgc) {
1517 0         0 push @char, $1;
1518             }
1519             elsif (/\G ($q_char) /oxmsgc) {
1520 0         0 push @char, $1;
1521             }
1522             }
1523              
1524             # join separated multiple-octet
1525 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1526              
1527             # unescape '-'
1528 0         0 my @i = ();
1529 0         0 for my $i (0 .. $#char) {
1530 0 0       0 if ($char[$i] eq '\-') {
    0          
1531 0         0 $char[$i] = '-';
1532             }
1533             elsif ($char[$i] eq '-') {
1534 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1535 0         0 push @i, $i;
1536             }
1537             }
1538             }
1539              
1540             # open character list (reverse for splice)
1541 0         0 for my $i (CORE::reverse @i) {
1542 0         0 my @range = ();
1543              
1544             # range error
1545 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1546 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1547             }
1548              
1549             # range of multiple-octet code
1550 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1551 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1552 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1553             }
1554             elsif (CORE::length($char[$i+1]) == 2) {
1555 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1556 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1557             }
1558             elsif (CORE::length($char[$i+1]) == 3) {
1559 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1560 0         0 push @range, chars2();
1561 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1562             }
1563             elsif (CORE::length($char[$i+1]) == 4) {
1564 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1565 0         0 push @range, chars2();
1566 0         0 push @range, chars3();
1567 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1568             }
1569             else {
1570 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1571             }
1572             }
1573             elsif (CORE::length($char[$i-1]) == 2) {
1574 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1575 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1576             }
1577             elsif (CORE::length($char[$i+1]) == 3) {
1578 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1579 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1580             }
1581             elsif (CORE::length($char[$i+1]) == 4) {
1582 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1583 0         0 push @range, chars3();
1584 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1585             }
1586             else {
1587 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1588             }
1589             }
1590             elsif (CORE::length($char[$i-1]) == 3) {
1591 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1592 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1593             }
1594             elsif (CORE::length($char[$i+1]) == 4) {
1595 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1596 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1597             }
1598             else {
1599 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1600             }
1601             }
1602             elsif (CORE::length($char[$i-1]) == 4) {
1603 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1604 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1605             }
1606             else {
1607 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1608             }
1609             }
1610             else {
1611 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1612             }
1613              
1614 0         0 splice @char, $i-1, 3, @range;
1615             }
1616              
1617 0         0 return @char;
1618             }
1619              
1620             #
1621             # GB18030 open character class
1622             #
1623             sub _cc {
1624 0 50   604   0 if (scalar(@_) == 0) {
    100          
    50          
1625 604         1383 die __FILE__, ": subroutine cc got no parameter.\n";
1626             }
1627             elsif (scalar(@_) == 1) {
1628 0         0 return sprintf('\x%02X',$_[0]);
1629             }
1630             elsif (scalar(@_) == 2) {
1631 302 50       960 if ($_[0] > $_[1]) {
    50          
    50          
1632 302         761 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1633             }
1634             elsif ($_[0] == $_[1]) {
1635 0         0 return sprintf('\x%02X',$_[0]);
1636             }
1637             elsif (($_[0]+1) == $_[1]) {
1638 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1639             }
1640             else {
1641 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1642             }
1643             }
1644             else {
1645 302         1726 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1646             }
1647             }
1648              
1649             #
1650             # GB18030 octet range
1651             #
1652             sub _octets {
1653 0     676   0 my $length = shift @_;
1654              
1655 676 100       3812 if ($length == 1) {
    50          
    0          
    0          
1656 676         1515 my($a1) = unpack 'C', $_[0];
1657 414         1285 my($z1) = unpack 'C', $_[1];
1658              
1659 414 50       976 if ($a1 > $z1) {
1660 414         1361 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1661             }
1662              
1663 0 100       0 if ($a1 == $z1) {
    50          
1664 414         1294 return sprintf('\x%02X',$a1);
1665             }
1666             elsif (($a1+1) == $z1) {
1667 20         89 return sprintf('\x%02X\x%02X',$a1,$z1);
1668             }
1669             else {
1670 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1671             }
1672             }
1673             elsif ($length == 2) {
1674 394         2640 my($a1,$a2) = unpack 'CC', $_[0];
1675 262         611 my($z1,$z2) = unpack 'CC', $_[1];
1676 262         495 my($A1,$A2) = unpack 'CC', $_[2];
1677 262         450 my($Z1,$Z2) = unpack 'CC', $_[3];
1678              
1679 262 100       403 if ($a1 == $z1) {
    50          
1680             return (
1681             # 11111111 222222222222
1682             # A A Z
1683 262         446 _cc($a1) . _cc($a2,$z2), # a2-z2
1684             );
1685             }
1686             elsif (($a1+1) == $z1) {
1687             return (
1688             # 11111111111 222222222222
1689             # A Z A Z
1690 222         423 _cc($a1) . _cc($a2,$Z2), # a2-
1691             _cc( $z1) . _cc($A2,$z2), # -z2
1692             );
1693             }
1694             else {
1695             return (
1696             # 1111111111111111 222222222222
1697             # A Z A Z
1698 40         74 _cc($a1) . _cc($a2,$Z2), # a2-
1699             _cc($a1+1,$z1-1) . _cc($A2,$Z2), # -
1700             _cc( $z1) . _cc($A2,$z2), # -z2
1701             );
1702             }
1703             }
1704             elsif ($length == 3) {
1705 0         0 my($a1,$a2,$a3) = unpack 'CCC', $_[0];
1706 0         0 my($z1,$z2,$z3) = unpack 'CCC', $_[1];
1707 0         0 my($A1,$A2,$A3) = unpack 'CCC', $_[2];
1708 0         0 my($Z1,$Z2,$Z3) = unpack 'CCC', $_[3];
1709              
1710 0 0       0 if ($a1 == $z1) {
    0          
1711 0 0       0 if ($a2 == $z2) {
    0          
1712             return (
1713             # 11111111 22222222 333333333333
1714             # A A A Z
1715 0         0 _cc($a1) . _cc($a2) . _cc($a3,$z3), # a3-z3
1716             );
1717             }
1718             elsif (($a2+1) == $z2) {
1719             return (
1720             # 11111111 22222222222 333333333333
1721             # A A Z A Z
1722 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1723             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1724             );
1725             }
1726             else {
1727             return (
1728             # 11111111 2222222222222222 333333333333
1729             # A A Z A Z
1730 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1731             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3), # -
1732             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1733             );
1734             }
1735             }
1736             elsif (($a1+1) == $z1) {
1737             return (
1738             # 11111111111 22222222222222 333333333333
1739             # A Z A Z A Z
1740 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1741             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1742             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1743             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1744             );
1745             }
1746             else {
1747             return (
1748             # 1111111111111111 22222222222222 333333333333
1749             # A Z A Z A Z
1750 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1751             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1752             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3), # -
1753             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1754             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1755             );
1756             }
1757             }
1758             elsif ($length == 4) {
1759 0         0 my($a1,$a2,$a3,$a4) = unpack 'CCCC', $_[0];
1760 0         0 my($z1,$z2,$z3,$z4) = unpack 'CCCC', $_[1];
1761 0         0 my($A1,$A2,$A3,$A4) = unpack 'CCCC', $_[0];
1762 0         0 my($Z1,$Z2,$Z3,$Z4) = unpack 'CCCC', $_[1];
1763              
1764 0 0       0 if ($a1 == $z1) {
    0          
1765 0 0       0 if ($a2 == $z2) {
    0          
1766 0 0       0 if ($a3 == $z3) {
    0          
1767             return (
1768             # 11111111 22222222 33333333 444444444444
1769             # A A A A Z
1770 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$z4), # a4-z4
1771             );
1772             }
1773             elsif (($a3+1) == $z3) {
1774             return (
1775             # 11111111 22222222 33333333333 444444444444
1776             # A A A Z A Z
1777 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1778             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1779             );
1780             }
1781             else {
1782             return (
1783             # 11111111 22222222 3333333333333333 444444444444
1784             # A A A Z A Z
1785 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1786             _cc($a1) . _cc($a2) . _cc($a3+1,$z3-1) . _cc($A4,$Z4), # -
1787             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1788             );
1789             }
1790             }
1791             elsif (($a2+1) == $z2) {
1792             return (
1793             # 11111111 22222222222 33333333333333 444444444444
1794             # A A Z A Z A Z
1795 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1796             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1797             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1798             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1799             );
1800             }
1801             else {
1802             return (
1803             # 11111111 2222222222222222 33333333333333 444444444444
1804             # A A Z A Z A Z
1805 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1806             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1807             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1808             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1809             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1810             );
1811             }
1812             }
1813             elsif (($a1+1) == $z1) {
1814             return (
1815             # 11111111111 22222222222222 33333333333333 444444444444
1816             # A Z A Z A Z A Z
1817 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1818             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1819             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1820             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1821             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1822             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1823             );
1824             }
1825             else {
1826             return (
1827             # 1111111111111111 22222222222222 33333333333333 444444444444
1828             # A Z A Z A Z A Z
1829 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1830             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1831             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1832             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1833             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1834             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1835             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1836             );
1837             }
1838             }
1839             else {
1840 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1841             }
1842             }
1843              
1844             #
1845             # GB18030 range regexp
1846             #
1847             sub _range_regexp {
1848 0     525   0 my($length,$first,$last) = @_;
1849              
1850 525         1605 my @range_regexp = ();
1851 525 50       822 if (not exists $range_tr{$length}) {
1852 525         1421 return @range_regexp;
1853             }
1854              
1855 0         0 my @ranges = @{ $range_tr{$length} };
  525         923  
1856 525         1389 while (my @range = splice(@ranges,0,$length)) {
1857 525         1786 my $min = '';
1858 1050         1679 my $max = '';
1859 1050         1515 for (my $i=0; $i < $length; $i++) {
1860 1050         2218 $min .= pack 'C', $range[$i][0];
1861 1312         3718 $max .= pack 'C', $range[$i][-1];
1862             }
1863              
1864             # min___max
1865             # FIRST_____________LAST
1866             # (nothing)
1867              
1868 1312 50 66     5678 if ($max lt $first) {
    100 100        
    50 33        
    100 100        
    100 66        
    100 66        
    50 66        
1869             }
1870              
1871             # **********
1872             # min_________max
1873             # FIRST_____________LAST
1874             # **********
1875              
1876             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1877 1050         10634 push @range_regexp, _octets($length,$first,$max,$min,$max);
1878             }
1879              
1880             # **********************
1881             # min________________max
1882             # FIRST_____________LAST
1883             # **********************
1884              
1885             elsif (($min eq $first) and ($max eq $last)) {
1886 20         59 push @range_regexp, _octets($length,$first,$last,$min,$max);
1887             }
1888              
1889             # *********
1890             # min___max
1891             # FIRST_____________LAST
1892             # *********
1893              
1894             elsif (($first le $min) and ($max le $last)) {
1895 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1896             }
1897              
1898             # **********************
1899             # min__________________________max
1900             # FIRST_____________LAST
1901             # **********************
1902              
1903             elsif (($min le $first) and ($last le $max)) {
1904 20         44 push @range_regexp, _octets($length,$first,$last,$min,$max);
1905             }
1906              
1907             # *********
1908             # min________max
1909             # FIRST_____________LAST
1910             # *********
1911              
1912             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1913 596         1881 push @range_regexp, _octets($length,$min,$last,$min,$max);
1914             }
1915              
1916             # min___max
1917             # FIRST_____________LAST
1918             # (nothing)
1919              
1920             elsif ($last lt $min) {
1921             }
1922              
1923             else {
1924 40         66 die __FILE__, ": subroutine _range_regexp panic.\n";
1925             }
1926             }
1927              
1928 0         0 return @range_regexp;
1929             }
1930              
1931             #
1932             # GB18030 open character list for qr and not qr
1933             #
1934             sub _charlist {
1935              
1936 525     766   1541 my $modifier = pop @_;
1937 766         1267 my @char = @_;
1938              
1939 766 100       4030 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1940              
1941             # unescape character
1942 766         2371 for (my $i=0; $i <= $#char; $i++) {
1943              
1944             # escape - to ...
1945 766 100 100     2532 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1946 2672 100 100     20556 if ((0 < $i) and ($i < $#char)) {
1947 530         1971 $char[$i] = '...';
1948             }
1949             }
1950              
1951             # octal escape sequence
1952             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1953 505         2443 $char[$i] = octchr($1);
1954             }
1955              
1956             # hexadecimal escape sequence
1957             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1958 0         0 $char[$i] = hexchr($1);
1959             }
1960              
1961             # \b{...} --> b\{...}
1962             # \B{...} --> B\{...}
1963             # \N{CHARNAME} --> N\{CHARNAME}
1964             # \p{PROPERTY} --> p\{PROPERTY}
1965             # \P{PROPERTY} --> P\{PROPERTY}
1966             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
1967 0         0 $char[$i] = $1 . '\\' . $2;
1968             }
1969              
1970             # \p, \P, \X --> p, P, X
1971             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1972 0         0 $char[$i] = $1;
1973             }
1974              
1975             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1976 0         0 $char[$i] = CORE::chr oct $1;
1977             }
1978             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1979 0         0 $char[$i] = CORE::chr hex $1;
1980             }
1981             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1982 206         871 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1983             }
1984             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1985             $char[$i] = {
1986             '\0' => "\0",
1987             '\n' => "\n",
1988             '\r' => "\r",
1989             '\t' => "\t",
1990             '\f' => "\f",
1991             '\b' => "\x08", # \b means backspace in character class
1992             '\a' => "\a",
1993             '\e' => "\e",
1994             '\d' => '[0-9]',
1995              
1996             # Vertical tabs are now whitespace
1997             # \s in a regex now matches a vertical tab in all circumstances.
1998             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1999             # \t \n \v \f \r space
2000             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
2001             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
2002             '\s' => '\s',
2003              
2004             '\w' => '[0-9A-Z_a-z]',
2005             '\D' => '${Egb18030::eD}',
2006             '\S' => '${Egb18030::eS}',
2007             '\W' => '${Egb18030::eW}',
2008              
2009             '\H' => '${Egb18030::eH}',
2010             '\V' => '${Egb18030::eV}',
2011             '\h' => '[\x09\x20]',
2012             '\v' => '[\x0A\x0B\x0C\x0D]',
2013             '\R' => '${Egb18030::eR}',
2014              
2015 0         0 }->{$1};
2016             }
2017              
2018             # POSIX-style character classes
2019             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
2020             $char[$i] = {
2021              
2022             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
2023             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
2024             '[:^lower:]' => '${Egb18030::not_lower_i}',
2025             '[:^upper:]' => '${Egb18030::not_upper_i}',
2026              
2027 33         614 }->{$1};
2028             }
2029             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
2030             $char[$i] = {
2031              
2032             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
2033             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
2034             '[:ascii:]' => '[\x00-\x7F]',
2035             '[:blank:]' => '[\x09\x20]',
2036             '[:cntrl:]' => '[\x00-\x1F\x7F]',
2037             '[:digit:]' => '[\x30-\x39]',
2038             '[:graph:]' => '[\x21-\x7F]',
2039             '[:lower:]' => '[\x61-\x7A]',
2040             '[:print:]' => '[\x20-\x7F]',
2041             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
2042              
2043             # P.174 POSIX-Style Character Classes
2044             # in Chapter 5: Pattern Matching
2045             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2046              
2047             # P.311 11.2.4 Character Classes and other Special Escapes
2048             # in Chapter 11: perlre: Perl regular expressions
2049             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2050              
2051             # P.210 POSIX-Style Character Classes
2052             # in Chapter 5: Pattern Matching
2053             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2054              
2055             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
2056              
2057             '[:upper:]' => '[\x41-\x5A]',
2058             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
2059             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
2060             '[:^alnum:]' => '${Egb18030::not_alnum}',
2061             '[:^alpha:]' => '${Egb18030::not_alpha}',
2062             '[:^ascii:]' => '${Egb18030::not_ascii}',
2063             '[:^blank:]' => '${Egb18030::not_blank}',
2064             '[:^cntrl:]' => '${Egb18030::not_cntrl}',
2065             '[:^digit:]' => '${Egb18030::not_digit}',
2066             '[:^graph:]' => '${Egb18030::not_graph}',
2067             '[:^lower:]' => '${Egb18030::not_lower}',
2068             '[:^print:]' => '${Egb18030::not_print}',
2069             '[:^punct:]' => '${Egb18030::not_punct}',
2070             '[:^space:]' => '${Egb18030::not_space}',
2071             '[:^upper:]' => '${Egb18030::not_upper}',
2072             '[:^word:]' => '${Egb18030::not_word}',
2073             '[:^xdigit:]' => '${Egb18030::not_xdigit}',
2074              
2075 8         65 }->{$1};
2076             }
2077             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
2078 70         1420 $char[$i] = $1;
2079             }
2080             }
2081              
2082             # open character list
2083 7         36 my @singleoctet = ();
2084 766         1657 my @multipleoctet = ();
2085 766         1083 for (my $i=0; $i <= $#char; ) {
2086              
2087             # escaped -
2088 766 100 100     2581 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
2089 2167         9426 $i += 1;
2090 505         736 next;
2091             }
2092              
2093             # make range regexp
2094             elsif ($char[$i] eq '...') {
2095              
2096             # range error
2097 505 50       925 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    100          
2098 505         2043 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2099             }
2100             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
2101 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
2102 485         1253 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2103             }
2104             }
2105              
2106             # make range regexp per length
2107 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
2108 505         1566 my @regexp = ();
2109              
2110             # is first and last
2111 525 100 100     978 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    100 33        
    50          
    50          
2112 525         2229 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
2113             }
2114              
2115             # is first
2116             elsif ($length == CORE::length($char[$i-1])) {
2117 485         1431 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
2118             }
2119              
2120             # is inside in first and last
2121             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
2122 20         94 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
2123             }
2124              
2125             # is last
2126             elsif ($length == CORE::length($char[$i+1])) {
2127 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
2128             }
2129              
2130             else {
2131 20         111 die __FILE__, ": subroutine make_regexp panic.\n";
2132             }
2133              
2134 0 100       0 if ($length == 1) {
2135 525         1168 push @singleoctet, @regexp;
2136             }
2137             else {
2138 394         979 push @multipleoctet, @regexp;
2139             }
2140             }
2141              
2142 131         323 $i += 2;
2143             }
2144              
2145             # with /i modifier
2146             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
2147 505 100       1587 if ($modifier =~ /i/oxms) {
2148 764         1386 my $uc = Egb18030::uc($char[$i]);
2149 192         409 my $fc = Egb18030::fc($char[$i]);
2150 192 50       338 if ($uc ne $fc) {
2151 192 50       328 if (CORE::length($fc) == 1) {
2152 192         268 push @singleoctet, $uc, $fc;
2153             }
2154             else {
2155 192         347 push @singleoctet, $uc;
2156 0         0 push @multipleoctet, $fc;
2157             }
2158             }
2159             else {
2160 0         0 push @singleoctet, $char[$i];
2161             }
2162             }
2163             else {
2164 0         0 push @singleoctet, $char[$i];
2165             }
2166 572         885 $i += 1;
2167             }
2168              
2169             # single character of single octet code
2170             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
2171 764         1547 push @singleoctet, "\t", "\x20";
2172 0         0 $i += 1;
2173             }
2174             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
2175 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
2176 0         0 $i += 1;
2177             }
2178             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
2179 0         0 push @singleoctet, $char[$i];
2180 2         6 $i += 1;
2181             }
2182              
2183             # single character of multiple-octet code
2184             else {
2185 2         5 push @multipleoctet, $char[$i];
2186 391         2696 $i += 1;
2187             }
2188             }
2189              
2190             # quote metachar
2191 391         728 for (@singleoctet) {
2192 766 50       1648 if ($_ eq '...') {
    100          
    100          
    100          
    100          
2193 1372         6393 $_ = '-';
2194             }
2195             elsif (/\A \n \z/oxms) {
2196 0         0 $_ = '\n';
2197             }
2198             elsif (/\A \r \z/oxms) {
2199 8         20 $_ = '\r';
2200             }
2201             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
2202 8         20 $_ = sprintf('\x%02X', CORE::ord $1);
2203             }
2204             elsif (/\A [\x00-\xFF] \z/oxms) {
2205 1         7 $_ = quotemeta $_;
2206             }
2207             }
2208 939         1584 for (@multipleoctet) {
2209 766 100       1587 if (/\A ([\x80-\xFF].*) ([\x00-\xFF]) \z/oxms) {
2210 693         1800 $_ = $1 . quotemeta $2;
2211             }
2212             }
2213              
2214             # return character list
2215 307         734 return \@singleoctet, \@multipleoctet;
2216             }
2217              
2218             #
2219             # GB18030 octal escape sequence
2220             #
2221             sub octchr {
2222 766     5 0 2912 my($octdigit) = @_;
2223              
2224 5         15 my @binary = ();
2225 5         9 for my $octal (split(//,$octdigit)) {
2226             push @binary, {
2227             '0' => '000',
2228             '1' => '001',
2229             '2' => '010',
2230             '3' => '011',
2231             '4' => '100',
2232             '5' => '101',
2233             '6' => '110',
2234             '7' => '111',
2235 5         34 }->{$octal};
2236             }
2237 50         187 my $binary = join '', @binary;
2238              
2239             my $octchr = {
2240             # 1234567
2241             1 => pack('B*', "0000000$binary"),
2242             2 => pack('B*', "000000$binary"),
2243             3 => pack('B*', "00000$binary"),
2244             4 => pack('B*', "0000$binary"),
2245             5 => pack('B*', "000$binary"),
2246             6 => pack('B*', "00$binary"),
2247             7 => pack('B*', "0$binary"),
2248             0 => pack('B*', "$binary"),
2249              
2250 5         17 }->{CORE::length($binary) % 8};
2251              
2252 5         66 return $octchr;
2253             }
2254              
2255             #
2256             # GB18030 hexadecimal escape sequence
2257             #
2258             sub hexchr {
2259 5     5 0 21 my($hexdigit) = @_;
2260              
2261             my $hexchr = {
2262             1 => pack('H*', "0$hexdigit"),
2263             0 => pack('H*', "$hexdigit"),
2264              
2265 5         16 }->{CORE::length($_[0]) % 2};
2266              
2267 5         38 return $hexchr;
2268             }
2269              
2270             #
2271             # GB18030 open character list for qr
2272             #
2273             sub charlist_qr {
2274              
2275 5     527 0 18 my $modifier = pop @_;
2276 527         1070 my @char = @_;
2277              
2278 527         2671 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2279 527         1823 my @singleoctet = @$singleoctet;
2280 527         1390 my @multipleoctet = @$multipleoctet;
2281              
2282             # return character list
2283 527 100       972 if (scalar(@singleoctet) >= 1) {
2284              
2285             # with /i modifier
2286 527 100       1314 if ($modifier =~ m/i/oxms) {
2287 392         964 my %singleoctet_ignorecase = ();
2288 107         155 for (@singleoctet) {
2289 107   100     176 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2290 272         1032 for my $ord (hex($1) .. hex($2)) {
2291 80         347 my $char = CORE::chr($ord);
2292 1046         1386 my $uc = Egb18030::uc($char);
2293 1046         1461 my $fc = Egb18030::fc($char);
2294 1046 100       1626 if ($uc eq $fc) {
2295 1046         1537 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2296             }
2297             else {
2298 457 50       1037 if (CORE::length($fc) == 1) {
2299 589         818 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2300 589         1183 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2301             }
2302             else {
2303 589         1426 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2304 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2305             }
2306             }
2307             }
2308             }
2309 0 100       0 if ($_ ne '') {
2310 272         501 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2311             }
2312             }
2313 192         487 my $i = 0;
2314 107         144 my @singleoctet_ignorecase = ();
2315 107         188 for my $ord (0 .. 255) {
2316 107 100       206 if (exists $singleoctet_ignorecase{$ord}) {
2317 27392         37178 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1444  
2318             }
2319             else {
2320 1577         2601 $i++;
2321             }
2322             }
2323 25815         30275 @singleoctet = ();
2324 107         208 for my $range (@singleoctet_ignorecase) {
2325 107 100       284 if (ref $range) {
2326 11412 100       18741 if (scalar(@{$range}) == 1) {
  214 50       271  
2327 214         502 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         7  
2328             }
2329 5         53 elsif (scalar(@{$range}) == 2) {
2330 209         297 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2331             }
2332             else {
2333 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         453  
  209         427  
2334             }
2335             }
2336             }
2337             }
2338              
2339 209         1074 my $not_anchor = '';
2340 392         894 $not_anchor = '(?![\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE])';
2341              
2342 392         794 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2343             }
2344 392 100       1526 if (scalar(@multipleoctet) >= 2) {
2345 527         1214 return '(?:' . join('|', @multipleoctet) . ')';
2346             }
2347             else {
2348 131         864 return $multipleoctet[0];
2349             }
2350             }
2351              
2352             #
2353             # GB18030 open character list for not qr
2354             #
2355             sub charlist_not_qr {
2356              
2357 396     239 0 1989 my $modifier = pop @_;
2358 239         442 my @char = @_;
2359              
2360 239         627 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2361 239         859 my @singleoctet = @$singleoctet;
2362 239         527 my @multipleoctet = @$multipleoctet;
2363              
2364             # with /i modifier
2365 239 100       426 if ($modifier =~ m/i/oxms) {
2366 239         678 my %singleoctet_ignorecase = ();
2367 128         232 for (@singleoctet) {
2368 128   100     234 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2369 272         923 for my $ord (hex($1) .. hex($2)) {
2370 80         337 my $char = CORE::chr($ord);
2371 1046         1452 my $uc = Egb18030::uc($char);
2372 1046         1420 my $fc = Egb18030::fc($char);
2373 1046 100       1597 if ($uc eq $fc) {
2374 1046         1573 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2375             }
2376             else {
2377 457 50       5119 if (CORE::length($fc) == 1) {
2378 589         830 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2379 589         1357 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2380             }
2381             else {
2382 589         1515 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2383 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2384             }
2385             }
2386             }
2387             }
2388 0 100       0 if ($_ ne '') {
2389 272         467 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2390             }
2391             }
2392 192         445 my $i = 0;
2393 128         213 my @singleoctet_ignorecase = ();
2394 128         200 for my $ord (0 .. 255) {
2395 128 100       254 if (exists $singleoctet_ignorecase{$ord}) {
2396 32768         38850 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1443  
2397             }
2398             else {
2399 1577         2753 $i++;
2400             }
2401             }
2402 31191         36345 @singleoctet = ();
2403 128         274 for my $range (@singleoctet_ignorecase) {
2404 128 100       333 if (ref $range) {
2405 11412 100       19373 if (scalar(@{$range}) == 1) {
  214 50       314  
2406 214         355 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         6  
2407             }
2408 5         65 elsif (scalar(@{$range}) == 2) {
2409 209         391 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2410             }
2411             else {
2412 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         277  
  209         254  
2413             }
2414             }
2415             }
2416             }
2417              
2418             # return character list
2419 209 100       977 if (scalar(@multipleoctet) >= 1) {
2420 239 100       642 if (scalar(@singleoctet) >= 1) {
2421              
2422             # any character other than multiple-octet and single octet character class
2423 114         232 return '(?!' . join('|', @multipleoctet) . ')(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])';
2424             }
2425             else {
2426              
2427             # any character other than multiple-octet character class
2428 70         574 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2429             }
2430             }
2431             else {
2432 44 50       334 if (scalar(@singleoctet) >= 1) {
2433              
2434             # any character other than single octet character class
2435 125         251 return '(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])';
2436             }
2437             else {
2438              
2439             # any character
2440 125         794 return "(?:$your_char)";
2441             }
2442             }
2443             }
2444              
2445             #
2446             # open file in read mode
2447             #
2448             sub _open_r {
2449 0     768   0 my(undef,$file) = @_;
2450 389     389   8416 use Fcntl qw(O_RDONLY);
  389         2622  
  389         69434  
2451 768         2418 return CORE::sysopen($_[0], $file, &O_RDONLY);
2452             }
2453              
2454             #
2455             # open file in append mode
2456             #
2457             sub _open_a {
2458 768     384   36688 my(undef,$file) = @_;
2459 389     389   9253 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  389         2313  
  389         6960407  
2460 384         1193 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2461             }
2462              
2463             #
2464             # safe system
2465             #
2466             sub _systemx {
2467              
2468             # P.707 29.2.33. exec
2469             # in Chapter 29: Functions
2470             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2471             #
2472             # Be aware that in older releases of Perl, exec (and system) did not flush
2473             # your output buffer, so you needed to enable command buffering by setting $|
2474             # on one or more filehandles to avoid lost output in the case of exec, or
2475             # misordererd output in the case of system. This situation was largely remedied
2476             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2477              
2478             # P.855 exec
2479             # in Chapter 27: Functions
2480             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2481             #
2482             # In very old release of Perl (before v5.6), exec (and system) did not flush
2483             # your output buffer, so you needed to enable command buffering by setting $|
2484             # on one or more filehandles to avoid lost output with exec or misordered
2485             # output with system.
2486              
2487 384     384   77081 $| = 1;
2488              
2489             # P.565 23.1.2. Cleaning Up Your Environment
2490             # in Chapter 23: Security
2491             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2492              
2493             # P.656 Cleaning Up Your Environment
2494             # in Chapter 20: Security
2495             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2496              
2497             # local $ENV{'PATH'} = '.';
2498 384         1422 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2499              
2500             # P.707 29.2.33. exec
2501             # in Chapter 29: Functions
2502             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2503             #
2504             # As we mentioned earlier, exec treats a discrete list of arguments as an
2505             # indication that it should bypass shell processing. However, there is one
2506             # place where you might still get tripped up. The exec call (and system, too)
2507             # will not distinguish between a single scalar argument and an array containing
2508             # only one element.
2509             #
2510             # @args = ("echo surprise"); # just one element in list
2511             # exec @args # still subject to shell escapes
2512             # or die "exec: $!"; # because @args == 1
2513             #
2514             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2515             # first argument as the pathname, which forces the rest of the arguments to be
2516             # interpreted as a list, even if there is only one of them:
2517             #
2518             # exec { $args[0] } @args # safe even with one-argument list
2519             # or die "can't exec @args: $!";
2520              
2521             # P.855 exec
2522             # in Chapter 27: Functions
2523             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2524             #
2525             # As we mentioned earlier, exec treats a discrete list of arguments as a
2526             # directive to bypass shell processing. However, there is one place where
2527             # you might still get tripped up. The exec call (and system, too) cannot
2528             # distinguish between a single scalar argument and an array containing
2529             # only one element.
2530             #
2531             # @args = ("echo surprise"); # just one element in list
2532             # exec @args # still subject to shell escapes
2533             # || die "exec: $!"; # because @args == 1
2534             #
2535             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2536             # argument as the pathname, which forces the rest of the arguments to be
2537             # interpreted as a list, even if there is only one of them:
2538             #
2539             # exec { $args[0] } @args # safe even with one-argument list
2540             # || die "can't exec @args: $!";
2541              
2542 384         3759 return CORE::system { $_[0] } @_; # safe even with one-argument list
  384         976  
2543             }
2544              
2545             #
2546             # GB18030 order to character (with parameter)
2547             #
2548             sub Egb18030::chr(;$) {
2549              
2550 384 0   0 0 61324051 my $c = @_ ? $_[0] : $_;
2551              
2552 0 0       0 if ($c == 0x00) {
2553 0         0 return "\x00";
2554             }
2555             else {
2556 0         0 my @chr = ();
2557 0         0 while ($c > 0) {
2558 0         0 unshift @chr, ($c % 0x100);
2559 0         0 $c = int($c / 0x100);
2560             }
2561 0         0 return pack 'C*', @chr;
2562             }
2563             }
2564              
2565             #
2566             # GB18030 order to character (without parameter)
2567             #
2568             sub Egb18030::chr_() {
2569              
2570 0     0 0 0 my $c = $_;
2571              
2572 0 0       0 if ($c == 0x00) {
2573 0         0 return "\x00";
2574             }
2575             else {
2576 0         0 my @chr = ();
2577 0         0 while ($c > 0) {
2578 0         0 unshift @chr, ($c % 0x100);
2579 0         0 $c = int($c / 0x100);
2580             }
2581 0         0 return pack 'C*', @chr;
2582             }
2583             }
2584              
2585             #
2586             # GB18030 stacked file test expr
2587             #
2588             sub Egb18030::filetest {
2589              
2590 0     0 0 0 my $file = pop @_;
2591 0         0 my $filetest = substr(pop @_, 1);
2592              
2593 0 0       0 unless (CORE::eval qq{Egb18030::$filetest(\$file)}) {
2594 0         0 return '';
2595             }
2596 0         0 for my $filetest (CORE::reverse @_) {
2597 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
2598 0         0 return '';
2599             }
2600             }
2601 0         0 return 1;
2602             }
2603              
2604             #
2605             # GB18030 file test -r expr
2606             #
2607             sub Egb18030::r(;*@) {
2608              
2609 0 0   0 0 0 local $_ = shift if @_;
2610 0 0 0     0 croak 'Too many arguments for -r (Egb18030::r)' if @_ and not wantarray;
2611              
2612 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2613 0 0       0 return wantarray ? (-r _,@_) : -r _;
2614             }
2615              
2616             # P.908 32.39. Symbol
2617             # in Chapter 32: Standard Modules
2618             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2619              
2620             # P.326 Prototypes
2621             # in Chapter 7: Subroutines
2622             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2623              
2624             # (and so on)
2625              
2626             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2627 0 0       0 return wantarray ? (-r $fh,@_) : -r $fh;
2628             }
2629             elsif (-e $_) {
2630 0 0       0 return wantarray ? (-r _,@_) : -r _;
2631             }
2632             elsif (_MSWin32_5Cended_path($_)) {
2633 0 0       0 if (-d "$_/.") {
2634 0 0       0 return wantarray ? (-r _,@_) : -r _;
2635             }
2636             else {
2637              
2638             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Egb18030::*()
2639             # on Windows opens the file for the path which has 5c at end.
2640             # (and so on)
2641              
2642 0         0 my $fh = gensym();
2643 0 0       0 if (_open_r($fh, $_)) {
2644 0         0 my $r = -r $fh;
2645 0 0       0 close($fh) or die "Can't close file: $_: $!";
2646 0 0       0 return wantarray ? ($r,@_) : $r;
2647             }
2648             }
2649             }
2650 0 0       0 return wantarray ? (undef,@_) : undef;
2651             }
2652              
2653             #
2654             # GB18030 file test -w expr
2655             #
2656             sub Egb18030::w(;*@) {
2657              
2658 0 0   0 0 0 local $_ = shift if @_;
2659 0 0 0     0 croak 'Too many arguments for -w (Egb18030::w)' if @_ and not wantarray;
2660              
2661 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2662 0 0       0 return wantarray ? (-w _,@_) : -w _;
2663             }
2664             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2665 0 0       0 return wantarray ? (-w $fh,@_) : -w $fh;
2666             }
2667             elsif (-e $_) {
2668 0 0       0 return wantarray ? (-w _,@_) : -w _;
2669             }
2670             elsif (_MSWin32_5Cended_path($_)) {
2671 0 0       0 if (-d "$_/.") {
2672 0 0       0 return wantarray ? (-w _,@_) : -w _;
2673             }
2674             else {
2675 0         0 my $fh = gensym();
2676 0 0       0 if (_open_a($fh, $_)) {
2677 0         0 my $w = -w $fh;
2678 0 0       0 close($fh) or die "Can't close file: $_: $!";
2679 0 0       0 return wantarray ? ($w,@_) : $w;
2680             }
2681             }
2682             }
2683 0 0       0 return wantarray ? (undef,@_) : undef;
2684             }
2685              
2686             #
2687             # GB18030 file test -x expr
2688             #
2689             sub Egb18030::x(;*@) {
2690              
2691 0 0   0 0 0 local $_ = shift if @_;
2692 0 0 0     0 croak 'Too many arguments for -x (Egb18030::x)' if @_ and not wantarray;
2693              
2694 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2695 0 0       0 return wantarray ? (-x _,@_) : -x _;
2696             }
2697             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2698 0 0       0 return wantarray ? (-x $fh,@_) : -x $fh;
2699             }
2700             elsif (-e $_) {
2701 0 0       0 return wantarray ? (-x _,@_) : -x _;
2702             }
2703             elsif (_MSWin32_5Cended_path($_)) {
2704 0 0       0 if (-d "$_/.") {
2705 0 0       0 return wantarray ? (-x _,@_) : -x _;
2706             }
2707             else {
2708 0         0 my $fh = gensym();
2709 0 0       0 if (_open_r($fh, $_)) {
2710 0         0 my $dummy_for_underline_cache = -x $fh;
2711 0 0       0 close($fh) or die "Can't close file: $_: $!";
2712             }
2713              
2714             # filename is not .COM .EXE .BAT .CMD
2715 0 0       0 return wantarray ? ('',@_) : '';
2716             }
2717             }
2718 0 0       0 return wantarray ? (undef,@_) : undef;
2719             }
2720              
2721             #
2722             # GB18030 file test -o expr
2723             #
2724             sub Egb18030::o(;*@) {
2725              
2726 0 0   0 0 0 local $_ = shift if @_;
2727 0 0 0     0 croak 'Too many arguments for -o (Egb18030::o)' if @_ and not wantarray;
2728              
2729 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2730 0 0       0 return wantarray ? (-o _,@_) : -o _;
2731             }
2732             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2733 0 0       0 return wantarray ? (-o $fh,@_) : -o $fh;
2734             }
2735             elsif (-e $_) {
2736 0 0       0 return wantarray ? (-o _,@_) : -o _;
2737             }
2738             elsif (_MSWin32_5Cended_path($_)) {
2739 0 0       0 if (-d "$_/.") {
2740 0 0       0 return wantarray ? (-o _,@_) : -o _;
2741             }
2742             else {
2743 0         0 my $fh = gensym();
2744 0 0       0 if (_open_r($fh, $_)) {
2745 0         0 my $o = -o $fh;
2746 0 0       0 close($fh) or die "Can't close file: $_: $!";
2747 0 0       0 return wantarray ? ($o,@_) : $o;
2748             }
2749             }
2750             }
2751 0 0       0 return wantarray ? (undef,@_) : undef;
2752             }
2753              
2754             #
2755             # GB18030 file test -R expr
2756             #
2757             sub Egb18030::R(;*@) {
2758              
2759 0 0   0 0 0 local $_ = shift if @_;
2760 0 0 0     0 croak 'Too many arguments for -R (Egb18030::R)' if @_ and not wantarray;
2761              
2762 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2763 0 0       0 return wantarray ? (-R _,@_) : -R _;
2764             }
2765             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2766 0 0       0 return wantarray ? (-R $fh,@_) : -R $fh;
2767             }
2768             elsif (-e $_) {
2769 0 0       0 return wantarray ? (-R _,@_) : -R _;
2770             }
2771             elsif (_MSWin32_5Cended_path($_)) {
2772 0 0       0 if (-d "$_/.") {
2773 0 0       0 return wantarray ? (-R _,@_) : -R _;
2774             }
2775             else {
2776 0         0 my $fh = gensym();
2777 0 0       0 if (_open_r($fh, $_)) {
2778 0         0 my $R = -R $fh;
2779 0 0       0 close($fh) or die "Can't close file: $_: $!";
2780 0 0       0 return wantarray ? ($R,@_) : $R;
2781             }
2782             }
2783             }
2784 0 0       0 return wantarray ? (undef,@_) : undef;
2785             }
2786              
2787             #
2788             # GB18030 file test -W expr
2789             #
2790             sub Egb18030::W(;*@) {
2791              
2792 0 0   0 0 0 local $_ = shift if @_;
2793 0 0 0     0 croak 'Too many arguments for -W (Egb18030::W)' if @_ and not wantarray;
2794              
2795 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2796 0 0       0 return wantarray ? (-W _,@_) : -W _;
2797             }
2798             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2799 0 0       0 return wantarray ? (-W $fh,@_) : -W $fh;
2800             }
2801             elsif (-e $_) {
2802 0 0       0 return wantarray ? (-W _,@_) : -W _;
2803             }
2804             elsif (_MSWin32_5Cended_path($_)) {
2805 0 0       0 if (-d "$_/.") {
2806 0 0       0 return wantarray ? (-W _,@_) : -W _;
2807             }
2808             else {
2809 0         0 my $fh = gensym();
2810 0 0       0 if (_open_a($fh, $_)) {
2811 0         0 my $W = -W $fh;
2812 0 0       0 close($fh) or die "Can't close file: $_: $!";
2813 0 0       0 return wantarray ? ($W,@_) : $W;
2814             }
2815             }
2816             }
2817 0 0       0 return wantarray ? (undef,@_) : undef;
2818             }
2819              
2820             #
2821             # GB18030 file test -X expr
2822             #
2823             sub Egb18030::X(;*@) {
2824              
2825 0 0   0 1 0 local $_ = shift if @_;
2826 0 0 0     0 croak 'Too many arguments for -X (Egb18030::X)' if @_ and not wantarray;
2827              
2828 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2829 0 0       0 return wantarray ? (-X _,@_) : -X _;
2830             }
2831             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2832 0 0       0 return wantarray ? (-X $fh,@_) : -X $fh;
2833             }
2834             elsif (-e $_) {
2835 0 0       0 return wantarray ? (-X _,@_) : -X _;
2836             }
2837             elsif (_MSWin32_5Cended_path($_)) {
2838 0 0       0 if (-d "$_/.") {
2839 0 0       0 return wantarray ? (-X _,@_) : -X _;
2840             }
2841             else {
2842 0         0 my $fh = gensym();
2843 0 0       0 if (_open_r($fh, $_)) {
2844 0         0 my $dummy_for_underline_cache = -X $fh;
2845 0 0       0 close($fh) or die "Can't close file: $_: $!";
2846             }
2847              
2848             # filename is not .COM .EXE .BAT .CMD
2849 0 0       0 return wantarray ? ('',@_) : '';
2850             }
2851             }
2852 0 0       0 return wantarray ? (undef,@_) : undef;
2853             }
2854              
2855             #
2856             # GB18030 file test -O expr
2857             #
2858             sub Egb18030::O(;*@) {
2859              
2860 0 0   0 0 0 local $_ = shift if @_;
2861 0 0 0     0 croak 'Too many arguments for -O (Egb18030::O)' if @_ and not wantarray;
2862              
2863 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2864 0 0       0 return wantarray ? (-O _,@_) : -O _;
2865             }
2866             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2867 0 0       0 return wantarray ? (-O $fh,@_) : -O $fh;
2868             }
2869             elsif (-e $_) {
2870 0 0       0 return wantarray ? (-O _,@_) : -O _;
2871             }
2872             elsif (_MSWin32_5Cended_path($_)) {
2873 0 0       0 if (-d "$_/.") {
2874 0 0       0 return wantarray ? (-O _,@_) : -O _;
2875             }
2876             else {
2877 0         0 my $fh = gensym();
2878 0 0       0 if (_open_r($fh, $_)) {
2879 0         0 my $O = -O $fh;
2880 0 0       0 close($fh) or die "Can't close file: $_: $!";
2881 0 0       0 return wantarray ? ($O,@_) : $O;
2882             }
2883             }
2884             }
2885 0 0       0 return wantarray ? (undef,@_) : undef;
2886             }
2887              
2888             #
2889             # GB18030 file test -e expr
2890             #
2891             sub Egb18030::e(;*@) {
2892              
2893 0 50   768 0 0 local $_ = shift if @_;
2894 768 50 33     3135 croak 'Too many arguments for -e (Egb18030::e)' if @_ and not wantarray;
2895              
2896 768         3519 local $^W = 0;
2897              
2898 768         2898 my $fh = qualify_to_ref $_;
2899 768 50       2283 if ($_ eq '_') {
    50          
    50          
    50          
    50          
2900 768 0       3513 return wantarray ? (-e _,@_) : -e _;
2901             }
2902              
2903             # return false if directory handle
2904             elsif (defined Egb18030::telldir($fh)) {
2905 0 0       0 return wantarray ? ('',@_) : '';
2906             }
2907              
2908             # return true if file handle
2909             elsif (defined fileno $fh) {
2910 0 0       0 return wantarray ? (1,@_) : 1;
2911             }
2912              
2913             elsif (-e $_) {
2914 0 0       0 return wantarray ? (1,@_) : 1;
2915             }
2916             elsif (_MSWin32_5Cended_path($_)) {
2917 0 0       0 if (-d "$_/.") {
2918 0 0       0 return wantarray ? (1,@_) : 1;
2919             }
2920             else {
2921 0         0 my $fh = gensym();
2922 0 0       0 if (_open_r($fh, $_)) {
2923 0         0 my $e = -e $fh;
2924 0 0       0 close($fh) or die "Can't close file: $_: $!";
2925 0 0       0 return wantarray ? ($e,@_) : $e;
2926             }
2927             }
2928             }
2929 0 50       0 return wantarray ? (undef,@_) : undef;
2930             }
2931              
2932             #
2933             # GB18030 file test -z expr
2934             #
2935             sub Egb18030::z(;*@) {
2936              
2937 768 0   0 0 4372 local $_ = shift if @_;
2938 0 0 0     0 croak 'Too many arguments for -z (Egb18030::z)' if @_ and not wantarray;
2939              
2940 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2941 0 0       0 return wantarray ? (-z _,@_) : -z _;
2942             }
2943             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2944 0 0       0 return wantarray ? (-z $fh,@_) : -z $fh;
2945             }
2946             elsif (-e $_) {
2947 0 0       0 return wantarray ? (-z _,@_) : -z _;
2948             }
2949             elsif (_MSWin32_5Cended_path($_)) {
2950 0 0       0 if (-d "$_/.") {
2951 0 0       0 return wantarray ? (-z _,@_) : -z _;
2952             }
2953             else {
2954 0         0 my $fh = gensym();
2955 0 0       0 if (_open_r($fh, $_)) {
2956 0         0 my $z = -z $fh;
2957 0 0       0 close($fh) or die "Can't close file: $_: $!";
2958 0 0       0 return wantarray ? ($z,@_) : $z;
2959             }
2960             }
2961             }
2962 0 0       0 return wantarray ? (undef,@_) : undef;
2963             }
2964              
2965             #
2966             # GB18030 file test -s expr
2967             #
2968             sub Egb18030::s(;*@) {
2969              
2970 0 0   0 0 0 local $_ = shift if @_;
2971 0 0 0     0 croak 'Too many arguments for -s (Egb18030::s)' if @_ and not wantarray;
2972              
2973 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2974 0 0       0 return wantarray ? (-s _,@_) : -s _;
2975             }
2976             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2977 0 0       0 return wantarray ? (-s $fh,@_) : -s $fh;
2978             }
2979             elsif (-e $_) {
2980 0 0       0 return wantarray ? (-s _,@_) : -s _;
2981             }
2982             elsif (_MSWin32_5Cended_path($_)) {
2983 0 0       0 if (-d "$_/.") {
2984 0 0       0 return wantarray ? (-s _,@_) : -s _;
2985             }
2986             else {
2987 0         0 my $fh = gensym();
2988 0 0       0 if (_open_r($fh, $_)) {
2989 0         0 my $s = -s $fh;
2990 0 0       0 close($fh) or die "Can't close file: $_: $!";
2991 0 0       0 return wantarray ? ($s,@_) : $s;
2992             }
2993             }
2994             }
2995 0 0       0 return wantarray ? (undef,@_) : undef;
2996             }
2997              
2998             #
2999             # GB18030 file test -f expr
3000             #
3001             sub Egb18030::f(;*@) {
3002              
3003 0 0   0 0 0 local $_ = shift if @_;
3004 0 0 0     0 croak 'Too many arguments for -f (Egb18030::f)' if @_ and not wantarray;
3005              
3006 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3007 0 0       0 return wantarray ? (-f _,@_) : -f _;
3008             }
3009             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3010 0 0       0 return wantarray ? (-f $fh,@_) : -f $fh;
3011             }
3012             elsif (-e $_) {
3013 0 0       0 return wantarray ? (-f _,@_) : -f _;
3014             }
3015             elsif (_MSWin32_5Cended_path($_)) {
3016 0 0       0 if (-d "$_/.") {
3017 0 0       0 return wantarray ? ('',@_) : '';
3018             }
3019             else {
3020 0         0 my $fh = gensym();
3021 0 0       0 if (_open_r($fh, $_)) {
3022 0         0 my $f = -f $fh;
3023 0 0       0 close($fh) or die "Can't close file: $_: $!";
3024 0 0       0 return wantarray ? ($f,@_) : $f;
3025             }
3026             }
3027             }
3028 0 0       0 return wantarray ? (undef,@_) : undef;
3029             }
3030              
3031             #
3032             # GB18030 file test -d expr
3033             #
3034             sub Egb18030::d(;*@) {
3035              
3036 0 0   0 0 0 local $_ = shift if @_;
3037 0 0 0     0 croak 'Too many arguments for -d (Egb18030::d)' if @_ and not wantarray;
3038              
3039 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3040 0 0       0 return wantarray ? (-d _,@_) : -d _;
3041             }
3042              
3043             # return false if file handle or directory handle
3044             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3045 0 0       0 return wantarray ? ('',@_) : '';
3046             }
3047             elsif (-e $_) {
3048 0 0       0 return wantarray ? (-d _,@_) : -d _;
3049             }
3050             elsif (_MSWin32_5Cended_path($_)) {
3051 0 0       0 return wantarray ? (-d "$_/.",@_) : -d "$_/.";
3052             }
3053 0 0       0 return wantarray ? (undef,@_) : undef;
3054             }
3055              
3056             #
3057             # GB18030 file test -l expr
3058             #
3059             sub Egb18030::l(;*@) {
3060              
3061 0 0   0 0 0 local $_ = shift if @_;
3062 0 0 0     0 croak 'Too many arguments for -l (Egb18030::l)' if @_ and not wantarray;
3063              
3064 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3065 0 0       0 return wantarray ? (-l _,@_) : -l _;
3066             }
3067             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3068 0 0       0 return wantarray ? (-l $fh,@_) : -l $fh;
3069             }
3070             elsif (-e $_) {
3071 0 0       0 return wantarray ? (-l _,@_) : -l _;
3072             }
3073             elsif (_MSWin32_5Cended_path($_)) {
3074 0 0       0 if (-d "$_/.") {
3075 0 0       0 return wantarray ? (-l _,@_) : -l _;
3076             }
3077             else {
3078 0         0 my $fh = gensym();
3079 0 0       0 if (_open_r($fh, $_)) {
3080 0         0 my $l = -l $fh;
3081 0 0       0 close($fh) or die "Can't close file: $_: $!";
3082 0 0       0 return wantarray ? ($l,@_) : $l;
3083             }
3084             }
3085             }
3086 0 0       0 return wantarray ? (undef,@_) : undef;
3087             }
3088              
3089             #
3090             # GB18030 file test -p expr
3091             #
3092             sub Egb18030::p(;*@) {
3093              
3094 0 0   0 0 0 local $_ = shift if @_;
3095 0 0 0     0 croak 'Too many arguments for -p (Egb18030::p)' if @_ and not wantarray;
3096              
3097 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3098 0 0       0 return wantarray ? (-p _,@_) : -p _;
3099             }
3100             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3101 0 0       0 return wantarray ? (-p $fh,@_) : -p $fh;
3102             }
3103             elsif (-e $_) {
3104 0 0       0 return wantarray ? (-p _,@_) : -p _;
3105             }
3106             elsif (_MSWin32_5Cended_path($_)) {
3107 0 0       0 if (-d "$_/.") {
3108 0 0       0 return wantarray ? (-p _,@_) : -p _;
3109             }
3110             else {
3111 0         0 my $fh = gensym();
3112 0 0       0 if (_open_r($fh, $_)) {
3113 0         0 my $p = -p $fh;
3114 0 0       0 close($fh) or die "Can't close file: $_: $!";
3115 0 0       0 return wantarray ? ($p,@_) : $p;
3116             }
3117             }
3118             }
3119 0 0       0 return wantarray ? (undef,@_) : undef;
3120             }
3121              
3122             #
3123             # GB18030 file test -S expr
3124             #
3125             sub Egb18030::S(;*@) {
3126              
3127 0 0   0 0 0 local $_ = shift if @_;
3128 0 0 0     0 croak 'Too many arguments for -S (Egb18030::S)' if @_ and not wantarray;
3129              
3130 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3131 0 0       0 return wantarray ? (-S _,@_) : -S _;
3132             }
3133             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3134 0 0       0 return wantarray ? (-S $fh,@_) : -S $fh;
3135             }
3136             elsif (-e $_) {
3137 0 0       0 return wantarray ? (-S _,@_) : -S _;
3138             }
3139             elsif (_MSWin32_5Cended_path($_)) {
3140 0 0       0 if (-d "$_/.") {
3141 0 0       0 return wantarray ? (-S _,@_) : -S _;
3142             }
3143             else {
3144 0         0 my $fh = gensym();
3145 0 0       0 if (_open_r($fh, $_)) {
3146 0         0 my $S = -S $fh;
3147 0 0       0 close($fh) or die "Can't close file: $_: $!";
3148 0 0       0 return wantarray ? ($S,@_) : $S;
3149             }
3150             }
3151             }
3152 0 0       0 return wantarray ? (undef,@_) : undef;
3153             }
3154              
3155             #
3156             # GB18030 file test -b expr
3157             #
3158             sub Egb18030::b(;*@) {
3159              
3160 0 0   0 0 0 local $_ = shift if @_;
3161 0 0 0     0 croak 'Too many arguments for -b (Egb18030::b)' if @_ and not wantarray;
3162              
3163 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3164 0 0       0 return wantarray ? (-b _,@_) : -b _;
3165             }
3166             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3167 0 0       0 return wantarray ? (-b $fh,@_) : -b $fh;
3168             }
3169             elsif (-e $_) {
3170 0 0       0 return wantarray ? (-b _,@_) : -b _;
3171             }
3172             elsif (_MSWin32_5Cended_path($_)) {
3173 0 0       0 if (-d "$_/.") {
3174 0 0       0 return wantarray ? (-b _,@_) : -b _;
3175             }
3176             else {
3177 0         0 my $fh = gensym();
3178 0 0       0 if (_open_r($fh, $_)) {
3179 0         0 my $b = -b $fh;
3180 0 0       0 close($fh) or die "Can't close file: $_: $!";
3181 0 0       0 return wantarray ? ($b,@_) : $b;
3182             }
3183             }
3184             }
3185 0 0       0 return wantarray ? (undef,@_) : undef;
3186             }
3187              
3188             #
3189             # GB18030 file test -c expr
3190             #
3191             sub Egb18030::c(;*@) {
3192              
3193 0 0   0 0 0 local $_ = shift if @_;
3194 0 0 0     0 croak 'Too many arguments for -c (Egb18030::c)' if @_ and not wantarray;
3195              
3196 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3197 0 0       0 return wantarray ? (-c _,@_) : -c _;
3198             }
3199             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3200 0 0       0 return wantarray ? (-c $fh,@_) : -c $fh;
3201             }
3202             elsif (-e $_) {
3203 0 0       0 return wantarray ? (-c _,@_) : -c _;
3204             }
3205             elsif (_MSWin32_5Cended_path($_)) {
3206 0 0       0 if (-d "$_/.") {
3207 0 0       0 return wantarray ? (-c _,@_) : -c _;
3208             }
3209             else {
3210 0         0 my $fh = gensym();
3211 0 0       0 if (_open_r($fh, $_)) {
3212 0         0 my $c = -c $fh;
3213 0 0       0 close($fh) or die "Can't close file: $_: $!";
3214 0 0       0 return wantarray ? ($c,@_) : $c;
3215             }
3216             }
3217             }
3218 0 0       0 return wantarray ? (undef,@_) : undef;
3219             }
3220              
3221             #
3222             # GB18030 file test -u expr
3223             #
3224             sub Egb18030::u(;*@) {
3225              
3226 0 0   0 0 0 local $_ = shift if @_;
3227 0 0 0     0 croak 'Too many arguments for -u (Egb18030::u)' if @_ and not wantarray;
3228              
3229 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3230 0 0       0 return wantarray ? (-u _,@_) : -u _;
3231             }
3232             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3233 0 0       0 return wantarray ? (-u $fh,@_) : -u $fh;
3234             }
3235             elsif (-e $_) {
3236 0 0       0 return wantarray ? (-u _,@_) : -u _;
3237             }
3238             elsif (_MSWin32_5Cended_path($_)) {
3239 0 0       0 if (-d "$_/.") {
3240 0 0       0 return wantarray ? (-u _,@_) : -u _;
3241             }
3242             else {
3243 0         0 my $fh = gensym();
3244 0 0       0 if (_open_r($fh, $_)) {
3245 0         0 my $u = -u $fh;
3246 0 0       0 close($fh) or die "Can't close file: $_: $!";
3247 0 0       0 return wantarray ? ($u,@_) : $u;
3248             }
3249             }
3250             }
3251 0 0       0 return wantarray ? (undef,@_) : undef;
3252             }
3253              
3254             #
3255             # GB18030 file test -g expr
3256             #
3257             sub Egb18030::g(;*@) {
3258              
3259 0 0   0 0 0 local $_ = shift if @_;
3260 0 0 0     0 croak 'Too many arguments for -g (Egb18030::g)' if @_ and not wantarray;
3261              
3262 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3263 0 0       0 return wantarray ? (-g _,@_) : -g _;
3264             }
3265             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3266 0 0       0 return wantarray ? (-g $fh,@_) : -g $fh;
3267             }
3268             elsif (-e $_) {
3269 0 0       0 return wantarray ? (-g _,@_) : -g _;
3270             }
3271             elsif (_MSWin32_5Cended_path($_)) {
3272 0 0       0 if (-d "$_/.") {
3273 0 0       0 return wantarray ? (-g _,@_) : -g _;
3274             }
3275             else {
3276 0         0 my $fh = gensym();
3277 0 0       0 if (_open_r($fh, $_)) {
3278 0         0 my $g = -g $fh;
3279 0 0       0 close($fh) or die "Can't close file: $_: $!";
3280 0 0       0 return wantarray ? ($g,@_) : $g;
3281             }
3282             }
3283             }
3284 0 0       0 return wantarray ? (undef,@_) : undef;
3285             }
3286              
3287             #
3288             # GB18030 file test -k expr
3289             #
3290             sub Egb18030::k(;*@) {
3291              
3292 0 0   0 0 0 local $_ = shift if @_;
3293 0 0 0     0 croak 'Too many arguments for -k (Egb18030::k)' if @_ and not wantarray;
3294              
3295 0 0       0 if ($_ eq '_') {
    0          
    0          
3296 0 0       0 return wantarray ? ('',@_) : '';
3297             }
3298             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3299 0 0       0 return wantarray ? ('',@_) : '';
3300             }
3301             elsif ($] =~ /^5\.008/oxms) {
3302 0 0       0 return wantarray ? ('',@_) : '';
3303             }
3304 0 0       0 return wantarray ? ($_,@_) : $_;
3305             }
3306              
3307             #
3308             # GB18030 file test -T expr
3309             #
3310             sub Egb18030::T(;*@) {
3311              
3312 0 0   0 0 0 local $_ = shift if @_;
3313              
3314             # Use of croak without parentheses makes die on Strawberry Perl 5.008 and 5.010, like:
3315             # croak 'Too many arguments for -T (Egb18030::T)';
3316             # Must be used by parentheses like:
3317             # croak('Too many arguments for -T (Egb18030::T)');
3318              
3319 0 0 0     0 if (@_ and not wantarray) {
3320 0         0 croak('Too many arguments for -T (Egb18030::T)');
3321             }
3322              
3323 0         0 my $T = 1;
3324              
3325 0         0 my $fh = qualify_to_ref $_;
3326 0 0       0 if (defined fileno $fh) {
3327              
3328 0 0       0 if (defined Egb18030::telldir($fh)) {
3329 0 0       0 return wantarray ? (undef,@_) : undef;
3330             }
3331              
3332             # P.813 29.2.176. tell
3333             # in Chapter 29: Functions
3334             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3335              
3336             # P.970 tell
3337             # in Chapter 27: Functions
3338             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3339              
3340             # (and so on)
3341              
3342 0         0 my $systell = sysseek $fh, 0, 1;
3343              
3344 0 0       0 if (sysread $fh, my $block, 512) {
3345              
3346             # P.163 Binary file check in Little Perl Parlor 16
3347             # of Book No. T1008901080816 ZASSHI 08901-8 UNIX MAGAZINE 1993 Aug VOL8#8
3348             # (and so on)
3349              
3350 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3351 0         0 $T = '';
3352             }
3353             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3354 0         0 $T = '';
3355             }
3356             }
3357              
3358             # 0 byte or eof
3359             else {
3360 0         0 $T = 1;
3361             }
3362              
3363 0         0 my $dummy_for_underline_cache = -T $fh;
3364 0         0 sysseek $fh, $systell, 0;
3365             }
3366             else {
3367 0 0 0     0 if (-d $_ or -d "$_/.") {
3368 0 0       0 return wantarray ? (undef,@_) : undef;
3369             }
3370              
3371 0         0 $fh = gensym();
3372 0 0       0 if (_open_r($fh, $_)) {
3373             }
3374             else {
3375 0 0       0 return wantarray ? (undef,@_) : undef;
3376             }
3377 0 0       0 if (sysread $fh, my $block, 512) {
3378 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3379 0         0 $T = '';
3380             }
3381             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3382 0         0 $T = '';
3383             }
3384             }
3385              
3386             # 0 byte or eof
3387             else {
3388 0         0 $T = 1;
3389             }
3390 0         0 my $dummy_for_underline_cache = -T $fh;
3391 0 0       0 close($fh) or die "Can't close file: $_: $!";
3392             }
3393              
3394 0 0       0 return wantarray ? ($T,@_) : $T;
3395             }
3396              
3397             #
3398             # GB18030 file test -B expr
3399             #
3400             sub Egb18030::B(;*@) {
3401              
3402 0 0   0 0 0 local $_ = shift if @_;
3403 0 0 0     0 croak 'Too many arguments for -B (Egb18030::B)' if @_ and not wantarray;
3404 0         0 my $B = '';
3405              
3406 0         0 my $fh = qualify_to_ref $_;
3407 0 0       0 if (defined fileno $fh) {
3408              
3409 0 0       0 if (defined Egb18030::telldir($fh)) {
3410 0 0       0 return wantarray ? (undef,@_) : undef;
3411             }
3412              
3413 0         0 my $systell = sysseek $fh, 0, 1;
3414              
3415 0 0       0 if (sysread $fh, my $block, 512) {
3416 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3417 0         0 $B = 1;
3418             }
3419             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3420 0         0 $B = 1;
3421             }
3422             }
3423              
3424             # 0 byte or eof
3425             else {
3426 0         0 $B = 1;
3427             }
3428              
3429 0         0 my $dummy_for_underline_cache = -B $fh;
3430 0         0 sysseek $fh, $systell, 0;
3431             }
3432             else {
3433 0 0 0     0 if (-d $_ or -d "$_/.") {
3434 0 0       0 return wantarray ? (undef,@_) : undef;
3435             }
3436              
3437 0         0 $fh = gensym();
3438 0 0       0 if (_open_r($fh, $_)) {
3439             }
3440             else {
3441 0 0       0 return wantarray ? (undef,@_) : undef;
3442             }
3443 0 0       0 if (sysread $fh, my $block, 512) {
3444 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3445 0         0 $B = 1;
3446             }
3447             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3448 0         0 $B = 1;
3449             }
3450             }
3451              
3452             # 0 byte or eof
3453             else {
3454 0         0 $B = 1;
3455             }
3456 0         0 my $dummy_for_underline_cache = -B $fh;
3457 0 0       0 close($fh) or die "Can't close file: $_: $!";
3458             }
3459              
3460 0 0       0 return wantarray ? ($B,@_) : $B;
3461             }
3462              
3463             #
3464             # GB18030 file test -M expr
3465             #
3466             sub Egb18030::M(;*@) {
3467              
3468 0 0   0 0 0 local $_ = shift if @_;
3469 0 0 0     0 croak 'Too many arguments for -M (Egb18030::M)' if @_ and not wantarray;
3470              
3471 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3472 0 0       0 return wantarray ? (-M _,@_) : -M _;
3473             }
3474             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3475 0 0       0 return wantarray ? (-M $fh,@_) : -M $fh;
3476             }
3477             elsif (-e $_) {
3478 0 0       0 return wantarray ? (-M _,@_) : -M _;
3479             }
3480             elsif (_MSWin32_5Cended_path($_)) {
3481 0 0       0 if (-d "$_/.") {
3482 0 0       0 return wantarray ? (-M _,@_) : -M _;
3483             }
3484             else {
3485 0         0 my $fh = gensym();
3486 0 0       0 if (_open_r($fh, $_)) {
3487 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3488 0 0       0 close($fh) or die "Can't close file: $_: $!";
3489 0         0 my $M = ($^T - $mtime) / (24*60*60);
3490 0 0       0 return wantarray ? ($M,@_) : $M;
3491             }
3492             }
3493             }
3494 0 0       0 return wantarray ? (undef,@_) : undef;
3495             }
3496              
3497             #
3498             # GB18030 file test -A expr
3499             #
3500             sub Egb18030::A(;*@) {
3501              
3502 0 0   0 0 0 local $_ = shift if @_;
3503 0 0 0     0 croak 'Too many arguments for -A (Egb18030::A)' if @_ and not wantarray;
3504              
3505 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3506 0 0       0 return wantarray ? (-A _,@_) : -A _;
3507             }
3508             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3509 0 0       0 return wantarray ? (-A $fh,@_) : -A $fh;
3510             }
3511             elsif (-e $_) {
3512 0 0       0 return wantarray ? (-A _,@_) : -A _;
3513             }
3514             elsif (_MSWin32_5Cended_path($_)) {
3515 0 0       0 if (-d "$_/.") {
3516 0 0       0 return wantarray ? (-A _,@_) : -A _;
3517             }
3518             else {
3519 0         0 my $fh = gensym();
3520 0 0       0 if (_open_r($fh, $_)) {
3521 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3522 0 0       0 close($fh) or die "Can't close file: $_: $!";
3523 0         0 my $A = ($^T - $atime) / (24*60*60);
3524 0 0       0 return wantarray ? ($A,@_) : $A;
3525             }
3526             }
3527             }
3528 0 0       0 return wantarray ? (undef,@_) : undef;
3529             }
3530              
3531             #
3532             # GB18030 file test -C expr
3533             #
3534             sub Egb18030::C(;*@) {
3535              
3536 0 0   0 0 0 local $_ = shift if @_;
3537 0 0 0     0 croak 'Too many arguments for -C (Egb18030::C)' if @_ and not wantarray;
3538              
3539 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3540 0 0       0 return wantarray ? (-C _,@_) : -C _;
3541             }
3542             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3543 0 0       0 return wantarray ? (-C $fh,@_) : -C $fh;
3544             }
3545             elsif (-e $_) {
3546 0 0       0 return wantarray ? (-C _,@_) : -C _;
3547             }
3548             elsif (_MSWin32_5Cended_path($_)) {
3549 0 0       0 if (-d "$_/.") {
3550 0 0       0 return wantarray ? (-C _,@_) : -C _;
3551             }
3552             else {
3553 0         0 my $fh = gensym();
3554 0 0       0 if (_open_r($fh, $_)) {
3555 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3556 0 0       0 close($fh) or die "Can't close file: $_: $!";
3557 0         0 my $C = ($^T - $ctime) / (24*60*60);
3558 0 0       0 return wantarray ? ($C,@_) : $C;
3559             }
3560             }
3561             }
3562 0 0       0 return wantarray ? (undef,@_) : undef;
3563             }
3564              
3565             #
3566             # GB18030 stacked file test $_
3567             #
3568             sub Egb18030::filetest_ {
3569              
3570 0     0 0 0 my $filetest = substr(pop @_, 1);
3571              
3572 0 0       0 unless (CORE::eval qq{Egb18030::${filetest}_}) {
3573 0         0 return '';
3574             }
3575 0         0 for my $filetest (CORE::reverse @_) {
3576 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
3577 0         0 return '';
3578             }
3579             }
3580 0         0 return 1;
3581             }
3582              
3583             #
3584             # GB18030 file test -r $_
3585             #
3586             sub Egb18030::r_() {
3587              
3588 0 0   0 0 0 if (-e $_) {
    0          
3589 0 0       0 return -r _ ? 1 : '';
3590             }
3591             elsif (_MSWin32_5Cended_path($_)) {
3592 0 0       0 if (-d "$_/.") {
3593 0 0       0 return -r _ ? 1 : '';
3594             }
3595             else {
3596 0         0 my $fh = gensym();
3597 0 0       0 if (_open_r($fh, $_)) {
3598 0         0 my $r = -r $fh;
3599 0 0       0 close($fh) or die "Can't close file: $_: $!";
3600 0 0       0 return $r ? 1 : '';
3601             }
3602             }
3603             }
3604              
3605             # 10.10. Returning Failure
3606             # in Chapter 10. Subroutines
3607             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3608             # (and so on)
3609              
3610             # 2010-01-26 The difference of "return;" and "return undef;"
3611             # http://d.hatena.ne.jp/gfx/20100126/1264474754
3612             #
3613             # "Perl Best Practices" recommends to use "return;"*1 to return nothing, but
3614             # it might be wrong in some cases. If you use this idiom for those functions
3615             # which are expected to return a scalar value, e.g. searching functions, the
3616             # user of those functions will be surprised at what they return in list
3617             # context, an empty list - note that many functions and all the methods
3618             # evaluate their arguments in list context. You'd better to use "return undef;"
3619             # for such scalar functions.
3620             #
3621             # sub search_something {
3622             # my($arg) = @_;
3623             # # search_something...
3624             # if(defined $found){
3625             # return $found;
3626             # }
3627             # return; # XXX: you'd better to "return undef;"
3628             # }
3629             #
3630             # # ...
3631             #
3632             # # you'll get what you want, but ...
3633             # my $something = search_something($source);
3634             #
3635             # # you won't get what you want here.
3636             # # @_ for doit() is (-foo => $opt), not (undef, -foo => $opt).
3637             # $obj->doit(search_something($source), -option=> $optval);
3638             #
3639             # # you have to use the "scalar" operator in such a case.
3640             # $obj->doit(scalar search_something($source), ...);
3641             #
3642             # *1: it returns an empty list in list context, or returns undef in scalar
3643             # context
3644             #
3645             # (and so on)
3646              
3647 0         0 return undef;
3648             }
3649              
3650             #
3651             # GB18030 file test -w $_
3652             #
3653             sub Egb18030::w_() {
3654              
3655 0 0   0 0 0 if (-e $_) {
    0          
3656 0 0       0 return -w _ ? 1 : '';
3657             }
3658             elsif (_MSWin32_5Cended_path($_)) {
3659 0 0       0 if (-d "$_/.") {
3660 0 0       0 return -w _ ? 1 : '';
3661             }
3662             else {
3663 0         0 my $fh = gensym();
3664 0 0       0 if (_open_a($fh, $_)) {
3665 0         0 my $w = -w $fh;
3666 0 0       0 close($fh) or die "Can't close file: $_: $!";
3667 0 0       0 return $w ? 1 : '';
3668             }
3669             }
3670             }
3671 0         0 return undef;
3672             }
3673              
3674             #
3675             # GB18030 file test -x $_
3676             #
3677             sub Egb18030::x_() {
3678              
3679 0 0   0 0 0 if (-e $_) {
    0          
3680 0 0       0 return -x _ ? 1 : '';
3681             }
3682             elsif (_MSWin32_5Cended_path($_)) {
3683 0 0       0 if (-d "$_/.") {
3684 0 0       0 return -x _ ? 1 : '';
3685             }
3686             else {
3687 0         0 my $fh = gensym();
3688 0 0       0 if (_open_r($fh, $_)) {
3689 0         0 my $dummy_for_underline_cache = -x $fh;
3690 0 0       0 close($fh) or die "Can't close file: $_: $!";
3691             }
3692              
3693             # filename is not .COM .EXE .BAT .CMD
3694 0         0 return '';
3695             }
3696             }
3697 0         0 return undef;
3698             }
3699              
3700             #
3701             # GB18030 file test -o $_
3702             #
3703             sub Egb18030::o_() {
3704              
3705 0 0   0 0 0 if (-e $_) {
    0          
3706 0 0       0 return -o _ ? 1 : '';
3707             }
3708             elsif (_MSWin32_5Cended_path($_)) {
3709 0 0       0 if (-d "$_/.") {
3710 0 0       0 return -o _ ? 1 : '';
3711             }
3712             else {
3713 0         0 my $fh = gensym();
3714 0 0       0 if (_open_r($fh, $_)) {
3715 0         0 my $o = -o $fh;
3716 0 0       0 close($fh) or die "Can't close file: $_: $!";
3717 0 0       0 return $o ? 1 : '';
3718             }
3719             }
3720             }
3721 0         0 return undef;
3722             }
3723              
3724             #
3725             # GB18030 file test -R $_
3726             #
3727             sub Egb18030::R_() {
3728              
3729 0 0   0 0 0 if (-e $_) {
    0          
3730 0 0       0 return -R _ ? 1 : '';
3731             }
3732             elsif (_MSWin32_5Cended_path($_)) {
3733 0 0       0 if (-d "$_/.") {
3734 0 0       0 return -R _ ? 1 : '';
3735             }
3736             else {
3737 0         0 my $fh = gensym();
3738 0 0       0 if (_open_r($fh, $_)) {
3739 0         0 my $R = -R $fh;
3740 0 0       0 close($fh) or die "Can't close file: $_: $!";
3741 0 0       0 return $R ? 1 : '';
3742             }
3743             }
3744             }
3745 0         0 return undef;
3746             }
3747              
3748             #
3749             # GB18030 file test -W $_
3750             #
3751             sub Egb18030::W_() {
3752              
3753 0 0   0 0 0 if (-e $_) {
    0          
3754 0 0       0 return -W _ ? 1 : '';
3755             }
3756             elsif (_MSWin32_5Cended_path($_)) {
3757 0 0       0 if (-d "$_/.") {
3758 0 0       0 return -W _ ? 1 : '';
3759             }
3760             else {
3761 0         0 my $fh = gensym();
3762 0 0       0 if (_open_a($fh, $_)) {
3763 0         0 my $W = -W $fh;
3764 0 0       0 close($fh) or die "Can't close file: $_: $!";
3765 0 0       0 return $W ? 1 : '';
3766             }
3767             }
3768             }
3769 0         0 return undef;
3770             }
3771              
3772             #
3773             # GB18030 file test -X $_
3774             #
3775             sub Egb18030::X_() {
3776              
3777 0 0   0 0 0 if (-e $_) {
    0          
3778 0 0       0 return -X _ ? 1 : '';
3779             }
3780             elsif (_MSWin32_5Cended_path($_)) {
3781 0 0       0 if (-d "$_/.") {
3782 0 0       0 return -X _ ? 1 : '';
3783             }
3784             else {
3785 0         0 my $fh = gensym();
3786 0 0       0 if (_open_r($fh, $_)) {
3787 0         0 my $dummy_for_underline_cache = -X $fh;
3788 0 0       0 close($fh) or die "Can't close file: $_: $!";
3789             }
3790              
3791             # filename is not .COM .EXE .BAT .CMD
3792 0         0 return '';
3793             }
3794             }
3795 0         0 return undef;
3796             }
3797              
3798             #
3799             # GB18030 file test -O $_
3800             #
3801             sub Egb18030::O_() {
3802              
3803 0 0   0 0 0 if (-e $_) {
    0          
3804 0 0       0 return -O _ ? 1 : '';
3805             }
3806             elsif (_MSWin32_5Cended_path($_)) {
3807 0 0       0 if (-d "$_/.") {
3808 0 0       0 return -O _ ? 1 : '';
3809             }
3810             else {
3811 0         0 my $fh = gensym();
3812 0 0       0 if (_open_r($fh, $_)) {
3813 0         0 my $O = -O $fh;
3814 0 0       0 close($fh) or die "Can't close file: $_: $!";
3815 0 0       0 return $O ? 1 : '';
3816             }
3817             }
3818             }
3819 0         0 return undef;
3820             }
3821              
3822             #
3823             # GB18030 file test -e $_
3824             #
3825             sub Egb18030::e_() {
3826              
3827 0 0   0 0 0 if (-e $_) {
    0          
3828 0         0 return 1;
3829             }
3830             elsif (_MSWin32_5Cended_path($_)) {
3831 0 0       0 if (-d "$_/.") {
3832 0         0 return 1;
3833             }
3834             else {
3835 0         0 my $fh = gensym();
3836 0 0       0 if (_open_r($fh, $_)) {
3837 0         0 my $e = -e $fh;
3838 0 0       0 close($fh) or die "Can't close file: $_: $!";
3839 0 0       0 return $e ? 1 : '';
3840             }
3841             }
3842             }
3843 0         0 return undef;
3844             }
3845              
3846             #
3847             # GB18030 file test -z $_
3848             #
3849             sub Egb18030::z_() {
3850              
3851 0 0   0 0 0 if (-e $_) {
    0          
3852 0 0       0 return -z _ ? 1 : '';
3853             }
3854             elsif (_MSWin32_5Cended_path($_)) {
3855 0 0       0 if (-d "$_/.") {
3856 0 0       0 return -z _ ? 1 : '';
3857             }
3858             else {
3859 0         0 my $fh = gensym();
3860 0 0       0 if (_open_r($fh, $_)) {
3861 0         0 my $z = -z $fh;
3862 0 0       0 close($fh) or die "Can't close file: $_: $!";
3863 0 0       0 return $z ? 1 : '';
3864             }
3865             }
3866             }
3867 0         0 return undef;
3868             }
3869              
3870             #
3871             # GB18030 file test -s $_
3872             #
3873             sub Egb18030::s_() {
3874              
3875 0 0   0 0 0 if (-e $_) {
    0          
3876 0         0 return -s _;
3877             }
3878             elsif (_MSWin32_5Cended_path($_)) {
3879 0 0       0 if (-d "$_/.") {
3880 0         0 return -s _;
3881             }
3882             else {
3883 0         0 my $fh = gensym();
3884 0 0       0 if (_open_r($fh, $_)) {
3885 0         0 my $s = -s $fh;
3886 0 0       0 close($fh) or die "Can't close file: $_: $!";
3887 0         0 return $s;
3888             }
3889             }
3890             }
3891 0         0 return undef;
3892             }
3893              
3894             #
3895             # GB18030 file test -f $_
3896             #
3897             sub Egb18030::f_() {
3898              
3899 0 0   0 0 0 if (-e $_) {
    0          
3900 0 0       0 return -f _ ? 1 : '';
3901             }
3902             elsif (_MSWin32_5Cended_path($_)) {
3903 0 0       0 if (-d "$_/.") {
3904 0         0 return '';
3905             }
3906             else {
3907 0         0 my $fh = gensym();
3908 0 0       0 if (_open_r($fh, $_)) {
3909 0         0 my $f = -f $fh;
3910 0 0       0 close($fh) or die "Can't close file: $_: $!";
3911 0 0       0 return $f ? 1 : '';
3912             }
3913             }
3914             }
3915 0         0 return undef;
3916             }
3917              
3918             #
3919             # GB18030 file test -d $_
3920             #
3921             sub Egb18030::d_() {
3922              
3923 0 0   0 0 0 if (-e $_) {
    0          
3924 0 0       0 return -d _ ? 1 : '';
3925             }
3926             elsif (_MSWin32_5Cended_path($_)) {
3927 0 0       0 return -d "$_/." ? 1 : '';
3928             }
3929 0         0 return undef;
3930             }
3931              
3932             #
3933             # GB18030 file test -l $_
3934             #
3935             sub Egb18030::l_() {
3936              
3937 0 0   0 0 0 if (-e $_) {
    0          
3938 0 0       0 return -l _ ? 1 : '';
3939             }
3940             elsif (_MSWin32_5Cended_path($_)) {
3941 0 0       0 if (-d "$_/.") {
3942 0 0       0 return -l _ ? 1 : '';
3943             }
3944             else {
3945 0         0 my $fh = gensym();
3946 0 0       0 if (_open_r($fh, $_)) {
3947 0         0 my $l = -l $fh;
3948 0 0       0 close($fh) or die "Can't close file: $_: $!";
3949 0 0       0 return $l ? 1 : '';
3950             }
3951             }
3952             }
3953 0         0 return undef;
3954             }
3955              
3956             #
3957             # GB18030 file test -p $_
3958             #
3959             sub Egb18030::p_() {
3960              
3961 0 0   0 0 0 if (-e $_) {
    0          
3962 0 0       0 return -p _ ? 1 : '';
3963             }
3964             elsif (_MSWin32_5Cended_path($_)) {
3965 0 0       0 if (-d "$_/.") {
3966 0 0       0 return -p _ ? 1 : '';
3967             }
3968             else {
3969 0         0 my $fh = gensym();
3970 0 0       0 if (_open_r($fh, $_)) {
3971 0         0 my $p = -p $fh;
3972 0 0       0 close($fh) or die "Can't close file: $_: $!";
3973 0 0       0 return $p ? 1 : '';
3974             }
3975             }
3976             }
3977 0         0 return undef;
3978             }
3979              
3980             #
3981             # GB18030 file test -S $_
3982             #
3983             sub Egb18030::S_() {
3984              
3985 0 0   0 0 0 if (-e $_) {
    0          
3986 0 0       0 return -S _ ? 1 : '';
3987             }
3988             elsif (_MSWin32_5Cended_path($_)) {
3989 0 0       0 if (-d "$_/.") {
3990 0 0       0 return -S _ ? 1 : '';
3991             }
3992             else {
3993 0         0 my $fh = gensym();
3994 0 0       0 if (_open_r($fh, $_)) {
3995 0         0 my $S = -S $fh;
3996 0 0       0 close($fh) or die "Can't close file: $_: $!";
3997 0 0       0 return $S ? 1 : '';
3998             }
3999             }
4000             }
4001 0         0 return undef;
4002             }
4003              
4004             #
4005             # GB18030 file test -b $_
4006             #
4007             sub Egb18030::b_() {
4008              
4009 0 0   0 0 0 if (-e $_) {
    0          
4010 0 0       0 return -b _ ? 1 : '';
4011             }
4012             elsif (_MSWin32_5Cended_path($_)) {
4013 0 0       0 if (-d "$_/.") {
4014 0 0       0 return -b _ ? 1 : '';
4015             }
4016             else {
4017 0         0 my $fh = gensym();
4018 0 0       0 if (_open_r($fh, $_)) {
4019 0         0 my $b = -b $fh;
4020 0 0       0 close($fh) or die "Can't close file: $_: $!";
4021 0 0       0 return $b ? 1 : '';
4022             }
4023             }
4024             }
4025 0         0 return undef;
4026             }
4027              
4028             #
4029             # GB18030 file test -c $_
4030             #
4031             sub Egb18030::c_() {
4032              
4033 0 0   0 0 0 if (-e $_) {
    0          
4034 0 0       0 return -c _ ? 1 : '';
4035             }
4036             elsif (_MSWin32_5Cended_path($_)) {
4037 0 0       0 if (-d "$_/.") {
4038 0 0       0 return -c _ ? 1 : '';
4039             }
4040             else {
4041 0         0 my $fh = gensym();
4042 0 0       0 if (_open_r($fh, $_)) {
4043 0         0 my $c = -c $fh;
4044 0 0       0 close($fh) or die "Can't close file: $_: $!";
4045 0 0       0 return $c ? 1 : '';
4046             }
4047             }
4048             }
4049 0         0 return undef;
4050             }
4051              
4052             #
4053             # GB18030 file test -u $_
4054             #
4055             sub Egb18030::u_() {
4056              
4057 0 0   0 0 0 if (-e $_) {
    0          
4058 0 0       0 return -u _ ? 1 : '';
4059             }
4060             elsif (_MSWin32_5Cended_path($_)) {
4061 0 0       0 if (-d "$_/.") {
4062 0 0       0 return -u _ ? 1 : '';
4063             }
4064             else {
4065 0         0 my $fh = gensym();
4066 0 0       0 if (_open_r($fh, $_)) {
4067 0         0 my $u = -u $fh;
4068 0 0       0 close($fh) or die "Can't close file: $_: $!";
4069 0 0       0 return $u ? 1 : '';
4070             }
4071             }
4072             }
4073 0         0 return undef;
4074             }
4075              
4076             #
4077             # GB18030 file test -g $_
4078             #
4079             sub Egb18030::g_() {
4080              
4081 0 0   0 0 0 if (-e $_) {
    0          
4082 0 0       0 return -g _ ? 1 : '';
4083             }
4084             elsif (_MSWin32_5Cended_path($_)) {
4085 0 0       0 if (-d "$_/.") {
4086 0 0       0 return -g _ ? 1 : '';
4087             }
4088             else {
4089 0         0 my $fh = gensym();
4090 0 0       0 if (_open_r($fh, $_)) {
4091 0         0 my $g = -g $fh;
4092 0 0       0 close($fh) or die "Can't close file: $_: $!";
4093 0 0       0 return $g ? 1 : '';
4094             }
4095             }
4096             }
4097 0         0 return undef;
4098             }
4099              
4100             #
4101             # GB18030 file test -k $_
4102             #
4103             sub Egb18030::k_() {
4104              
4105 0 0   0 0 0 if ($] =~ /^5\.008/oxms) {
4106 0 0       0 return wantarray ? ('',@_) : '';
4107             }
4108 0 0       0 return wantarray ? ($_,@_) : $_;
4109             }
4110              
4111             #
4112             # GB18030 file test -T $_
4113             #
4114             sub Egb18030::T_() {
4115              
4116 0     0 0 0 my $T = 1;
4117              
4118 0 0 0     0 if (-d $_ or -d "$_/.") {
4119 0         0 return undef;
4120             }
4121 0         0 my $fh = gensym();
4122 0 0       0 if (_open_r($fh, $_)) {
4123             }
4124             else {
4125 0         0 return undef;
4126             }
4127              
4128 0 0       0 if (sysread $fh, my $block, 512) {
4129 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4130 0         0 $T = '';
4131             }
4132             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4133 0         0 $T = '';
4134             }
4135             }
4136              
4137             # 0 byte or eof
4138             else {
4139 0         0 $T = 1;
4140             }
4141 0         0 my $dummy_for_underline_cache = -T $fh;
4142 0 0       0 close($fh) or die "Can't close file: $_: $!";
4143              
4144 0         0 return $T;
4145             }
4146              
4147             #
4148             # GB18030 file test -B $_
4149             #
4150             sub Egb18030::B_() {
4151              
4152 0     0 0 0 my $B = '';
4153              
4154 0 0 0     0 if (-d $_ or -d "$_/.") {
4155 0         0 return undef;
4156             }
4157 0         0 my $fh = gensym();
4158 0 0       0 if (_open_r($fh, $_)) {
4159             }
4160             else {
4161 0         0 return undef;
4162             }
4163              
4164 0 0       0 if (sysread $fh, my $block, 512) {
4165 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4166 0         0 $B = 1;
4167             }
4168             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4169 0         0 $B = 1;
4170             }
4171             }
4172              
4173             # 0 byte or eof
4174             else {
4175 0         0 $B = 1;
4176             }
4177 0         0 my $dummy_for_underline_cache = -B $fh;
4178 0 0       0 close($fh) or die "Can't close file: $_: $!";
4179              
4180 0         0 return $B;
4181             }
4182              
4183             #
4184             # GB18030 file test -M $_
4185             #
4186             sub Egb18030::M_() {
4187              
4188 0 0   0 0 0 if (-e $_) {
    0          
4189 0         0 return -M _;
4190             }
4191             elsif (_MSWin32_5Cended_path($_)) {
4192 0 0       0 if (-d "$_/.") {
4193 0         0 return -M _;
4194             }
4195             else {
4196 0         0 my $fh = gensym();
4197 0 0       0 if (_open_r($fh, $_)) {
4198 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4199 0 0       0 close($fh) or die "Can't close file: $_: $!";
4200 0         0 my $M = ($^T - $mtime) / (24*60*60);
4201 0         0 return $M;
4202             }
4203             }
4204             }
4205 0         0 return undef;
4206             }
4207              
4208             #
4209             # GB18030 file test -A $_
4210             #
4211             sub Egb18030::A_() {
4212              
4213 0 0   0 0 0 if (-e $_) {
    0          
4214 0         0 return -A _;
4215             }
4216             elsif (_MSWin32_5Cended_path($_)) {
4217 0 0       0 if (-d "$_/.") {
4218 0         0 return -A _;
4219             }
4220             else {
4221 0         0 my $fh = gensym();
4222 0 0       0 if (_open_r($fh, $_)) {
4223 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4224 0 0       0 close($fh) or die "Can't close file: $_: $!";
4225 0         0 my $A = ($^T - $atime) / (24*60*60);
4226 0         0 return $A;
4227             }
4228             }
4229             }
4230 0         0 return undef;
4231             }
4232              
4233             #
4234             # GB18030 file test -C $_
4235             #
4236             sub Egb18030::C_() {
4237              
4238 0 0   0 0 0 if (-e $_) {
    0          
4239 0         0 return -C _;
4240             }
4241             elsif (_MSWin32_5Cended_path($_)) {
4242 0 0       0 if (-d "$_/.") {
4243 0         0 return -C _;
4244             }
4245             else {
4246 0         0 my $fh = gensym();
4247 0 0       0 if (_open_r($fh, $_)) {
4248 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4249 0 0       0 close($fh) or die "Can't close file: $_: $!";
4250 0         0 my $C = ($^T - $ctime) / (24*60*60);
4251 0         0 return $C;
4252             }
4253             }
4254             }
4255 0         0 return undef;
4256             }
4257              
4258             #
4259             # GB18030 path globbing (with parameter)
4260             #
4261             sub Egb18030::glob($) {
4262              
4263 0 0   0 0 0 if (wantarray) {
4264 0         0 my @glob = _DOS_like_glob(@_);
4265 0         0 for my $glob (@glob) {
4266 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4267             }
4268 0         0 return @glob;
4269             }
4270             else {
4271 0         0 my $glob = _DOS_like_glob(@_);
4272 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4273 0         0 return $glob;
4274             }
4275             }
4276              
4277             #
4278             # GB18030 path globbing (without parameter)
4279             #
4280             sub Egb18030::glob_() {
4281              
4282 0 0   0 0 0 if (wantarray) {
4283 0         0 my @glob = _DOS_like_glob();
4284 0         0 for my $glob (@glob) {
4285 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4286             }
4287 0         0 return @glob;
4288             }
4289             else {
4290 0         0 my $glob = _DOS_like_glob();
4291 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4292 0         0 return $glob;
4293             }
4294             }
4295              
4296             #
4297             # GB18030 path globbing via File::DosGlob 1.10
4298             #
4299             # Often I confuse "_dosglob" and "_doglob".
4300             # So, I renamed "_dosglob" to "_DOS_like_glob".
4301             #
4302             my %iter;
4303             my %entries;
4304             sub _DOS_like_glob {
4305              
4306             # context (keyed by second cxix argument provided by core)
4307 0     0   0 my($expr,$cxix) = @_;
4308              
4309             # glob without args defaults to $_
4310 0 0       0 $expr = $_ if not defined $expr;
4311              
4312             # represents the current user's home directory
4313             #
4314             # 7.3. Expanding Tildes in Filenames
4315             # in Chapter 7. File Access
4316             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4317             #
4318             # and File::HomeDir, File::HomeDir::Windows module
4319              
4320             # DOS-like system
4321 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4322 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
4323             { my_home_MSWin32() }oxmse;
4324             }
4325              
4326             # UNIX-like system
4327 0 0 0     0 else {
  0         0  
4328             $expr =~ s{ \A ~ ( (?:[^\x81-\xFE/]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])* ) }
4329             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
4330             }
4331 0 0       0  
4332 0 0       0 # assume global context if not provided one
4333             $cxix = '_G_' if not defined $cxix;
4334             $iter{$cxix} = 0 if not exists $iter{$cxix};
4335 0 0       0  
4336 0         0 # if we're just beginning, do it all first
4337             if ($iter{$cxix} == 0) {
4338             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
4339             }
4340 0 0       0  
4341 0         0 # chuck it all out, quick or slow
4342 0         0 if (wantarray) {
  0         0  
4343             delete $iter{$cxix};
4344             return @{delete $entries{$cxix}};
4345 0 0       0 }
  0         0  
4346 0         0 else {
  0         0  
4347             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
4348             return shift @{$entries{$cxix}};
4349             }
4350 0         0 else {
4351 0         0 # return undef for EOL
4352 0         0 delete $iter{$cxix};
4353             delete $entries{$cxix};
4354             return undef;
4355             }
4356             }
4357             }
4358              
4359             #
4360             # GB18030 path globbing subroutine
4361             #
4362 0     0   0 sub _do_glob {
4363 0         0  
4364 0         0 my($cond,@expr) = @_;
4365             my @glob = ();
4366             my $fix_drive_relative_paths = 0;
4367 0         0  
4368 0 0       0 OUTER:
4369 0 0       0 for my $expr (@expr) {
4370             next OUTER if not defined $expr;
4371 0         0 next OUTER if $expr eq '';
4372 0         0  
4373 0         0 my @matched = ();
4374 0         0 my @globdir = ();
4375 0         0 my $head = '.';
4376             my $pathsep = '/';
4377             my $tail;
4378 0 0       0  
4379 0         0 # if argument is within quotes strip em and do no globbing
4380 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
4381 0 0       0 $expr = $1;
4382 0         0 if ($cond eq 'd') {
4383             if (Egb18030::d $expr) {
4384             push @glob, $expr;
4385             }
4386 0 0       0 }
4387 0         0 else {
4388             if (Egb18030::e $expr) {
4389             push @glob, $expr;
4390 0         0 }
4391             }
4392             next OUTER;
4393             }
4394              
4395 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
4396 0 0       0 # to h:./*.pm to expand correctly
4397 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4398             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^\x81-\xFE/\\]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF]) #$1./$2#oxms) {
4399             $fix_drive_relative_paths = 1;
4400             }
4401 0 0       0 }
4402 0 0       0  
4403 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
4404 0         0 if ($tail eq '') {
4405             push @glob, $expr;
4406 0 0       0 next OUTER;
4407 0 0       0 }
4408 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
4409 0         0 if (@globdir = _do_glob('d', $head)) {
4410             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
4411             next OUTER;
4412 0 0 0     0 }
4413 0         0 }
4414             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
4415 0         0 $head .= $pathsep;
4416             }
4417             $expr = $tail;
4418             }
4419 0 0       0  
4420 0 0       0 # If file component has no wildcards, we can avoid opendir
4421 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
4422             if ($head eq '.') {
4423 0 0 0     0 $head = '';
4424 0         0 }
4425             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4426 0         0 $head .= $pathsep;
4427 0 0       0 }
4428 0 0       0 $head .= $expr;
4429 0         0 if ($cond eq 'd') {
4430             if (Egb18030::d $head) {
4431             push @glob, $head;
4432             }
4433 0 0       0 }
4434 0         0 else {
4435             if (Egb18030::e $head) {
4436             push @glob, $head;
4437 0         0 }
4438             }
4439 0 0       0 next OUTER;
4440 0         0 }
4441 0         0 Egb18030::opendir(*DIR, $head) or next OUTER;
4442             my @leaf = readdir DIR;
4443 0 0       0 closedir DIR;
4444 0         0  
4445             if ($head eq '.') {
4446 0 0 0     0 $head = '';
4447 0         0 }
4448             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4449             $head .= $pathsep;
4450 0         0 }
4451 0         0  
4452 0         0 my $pattern = '';
4453             while ($expr =~ / \G ($q_char) /oxgc) {
4454             my $char = $1;
4455              
4456             # 6.9. Matching Shell Globs as Regular Expressions
4457             # in Chapter 6. Pattern Matching
4458             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4459 0 0       0 # (and so on)
    0          
    0          
4460 0         0  
4461             if ($char eq '*') {
4462             $pattern .= "(?:$your_char)*",
4463 0         0 }
4464             elsif ($char eq '?') {
4465             $pattern .= "(?:$your_char)?", # DOS style
4466             # $pattern .= "(?:$your_char)", # UNIX style
4467 0         0 }
4468             elsif ((my $fc = Egb18030::fc($char)) ne $char) {
4469             $pattern .= $fc;
4470 0         0 }
4471             else {
4472             $pattern .= quotemeta $char;
4473 0     0   0 }
  0         0  
4474             }
4475             my $matchsub = sub { Egb18030::fc($_[0]) =~ /\A $pattern \z/xms };
4476              
4477             # if ($@) {
4478             # print STDERR "$0: $@\n";
4479             # next OUTER;
4480             # }
4481 0         0  
4482 0 0 0     0 INNER:
4483 0         0 for my $leaf (@leaf) {
4484             if ($leaf eq '.' or $leaf eq '..') {
4485 0 0 0     0 next INNER;
4486 0         0 }
4487             if ($cond eq 'd' and not Egb18030::d "$head$leaf") {
4488             next INNER;
4489 0 0       0 }
4490 0         0  
4491 0         0 if (&$matchsub($leaf)) {
4492             push @matched, "$head$leaf";
4493             next INNER;
4494             }
4495              
4496             # [DOS compatibility special case]
4497 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
4498              
4499             if (Egb18030::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
4500             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
4501 0 0       0 Egb18030::index($pattern,'\\.') != -1 # pattern has a dot.
4502 0         0 ) {
4503 0         0 if (&$matchsub("$leaf.")) {
4504             push @matched, "$head$leaf";
4505             next INNER;
4506             }
4507 0 0       0 }
4508 0         0 }
4509             if (@matched) {
4510             push @glob, @matched;
4511 0 0       0 }
4512 0         0 }
4513 0         0 if ($fix_drive_relative_paths) {
4514             for my $glob (@glob) {
4515             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
4516 0         0 }
4517             }
4518             return @glob;
4519             }
4520              
4521             #
4522             # GB18030 parse line
4523             #
4524 0     0   0 sub _parse_line {
4525              
4526 0         0 my($line) = @_;
4527 0         0  
4528 0         0 $line .= ' ';
4529             my @piece = ();
4530             while ($line =~ /
4531             " ( (?>(?: [^\x81-\xFE"] |[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] )* ) ) " (?>\s+) |
4532             ( (?>(?: [^\x81-\xFE"\s]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] )* ) ) (?>\s+)
4533 0 0       0 /oxmsg
4534             ) {
4535 0         0 push @piece, defined($1) ? $1 : $2;
4536             }
4537             return @piece;
4538             }
4539              
4540             #
4541             # GB18030 parse path
4542             #
4543 0     0   0 sub _parse_path {
4544              
4545 0         0 my($path,$pathsep) = @_;
4546 0         0  
4547 0         0 $path .= '/';
4548             my @subpath = ();
4549             while ($path =~ /
4550             ((?: [^\x81-\xFE\/\\]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] )+?) [\/\\]
4551 0         0 /oxmsg
4552             ) {
4553             push @subpath, $1;
4554 0         0 }
4555 0         0  
4556 0         0 my $tail = pop @subpath;
4557             my $head = join $pathsep, @subpath;
4558             return $head, $tail;
4559             }
4560              
4561             #
4562             # via File::HomeDir::Windows 1.00
4563             #
4564             sub my_home_MSWin32 {
4565              
4566             # A lot of unix people and unix-derived tools rely on
4567 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
4568 0         0 # so that they can replace raw HOME calls with File::HomeDir.
4569             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
4570             return $ENV{'HOME'};
4571             }
4572              
4573 0         0 # Do we have a user profile?
4574             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
4575             return $ENV{'USERPROFILE'};
4576             }
4577              
4578 0         0 # Some Windows use something like $ENV{'HOME'}
4579             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
4580             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
4581 0         0 }
4582              
4583             return undef;
4584             }
4585              
4586             #
4587             # via File::HomeDir::Unix 1.00
4588 0     0 0 0 #
4589             sub my_home {
4590 0 0 0     0 my $home;
    0 0        
4591 0         0  
4592             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
4593             $home = $ENV{'HOME'};
4594             }
4595              
4596             # This is from the original code, but I'm guessing
4597 0         0 # it means "login directory" and exists on some Unixes.
4598             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
4599             $home = $ENV{'LOGDIR'};
4600             }
4601              
4602             ### More-desperate methods
4603              
4604 0         0 # Light desperation on any (Unixish) platform
4605             else {
4606             $home = CORE::eval q{ (getpwuid($<))[7] };
4607             }
4608              
4609 0 0 0     0 # On Unix in general, a non-existant home means "no home"
4610 0         0 # For example, "nobody"-like users might use /nonexistant
4611             if (defined $home and ! Egb18030::d($home)) {
4612 0         0 $home = undef;
4613             }
4614             return $home;
4615             }
4616              
4617             #
4618             # GB18030 file lstat (with parameter)
4619             #
4620 0 0   0 0 0 sub Egb18030::lstat(*) {
4621              
4622 0 0       0 local $_ = shift if @_;
    0          
4623 0         0  
4624             if (-e $_) {
4625             return CORE::lstat _;
4626             }
4627             elsif (_MSWin32_5Cended_path($_)) {
4628              
4629             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Egb18030::lstat()
4630             # on Windows opens the file for the path which has 5c at end.
4631 0         0 # (and so on)
4632 0 0       0  
4633 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4634 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4635 0 0       0 if (wantarray) {
4636 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4637             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4638             return @stat;
4639 0         0 }
4640 0 0       0 else {
4641 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4642             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4643             return $stat;
4644             }
4645 0 0       0 }
4646             }
4647             return wantarray ? () : undef;
4648             }
4649              
4650             #
4651             # GB18030 file lstat (without parameter)
4652             #
4653 0 0   0 0 0 sub Egb18030::lstat_() {
    0          
4654 0         0  
4655             if (-e $_) {
4656             return CORE::lstat _;
4657 0         0 }
4658 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4659 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4660 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4661 0 0       0 if (wantarray) {
4662 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4663             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4664             return @stat;
4665 0         0 }
4666 0 0       0 else {
4667 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4668             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4669             return $stat;
4670             }
4671 0 0       0 }
4672             }
4673             return wantarray ? () : undef;
4674             }
4675              
4676             #
4677             # GB18030 path opendir
4678             #
4679 0     0 0 0 sub Egb18030::opendir(*$) {
4680 0 0       0  
    0          
4681 0         0 my $dh = qualify_to_ref $_[0];
4682             if (CORE::opendir $dh, $_[1]) {
4683             return 1;
4684 0 0       0 }
4685 0         0 elsif (_MSWin32_5Cended_path($_[1])) {
4686             if (CORE::opendir $dh, "$_[1]/.") {
4687             return 1;
4688 0         0 }
4689             }
4690             return undef;
4691             }
4692              
4693             #
4694             # GB18030 file stat (with parameter)
4695             #
4696 0 50   384 0 0 sub Egb18030::stat(*) {
4697              
4698 384         2579 local $_ = shift if @_;
4699 384 50       2579  
    50          
    0          
4700 384         15271 my $fh = qualify_to_ref $_;
4701             if (defined fileno $fh) {
4702             return CORE::stat $fh;
4703 0         0 }
4704             elsif (-e $_) {
4705             return CORE::stat _;
4706             }
4707             elsif (_MSWin32_5Cended_path($_)) {
4708              
4709             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Egb18030::stat()
4710             # on Windows opens the file for the path which has 5c at end.
4711 384         3034 # (and so on)
4712 0 0       0  
4713 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4714 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4715 0 0       0 if (wantarray) {
4716 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4717             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4718             return @stat;
4719 0         0 }
4720 0 0       0 else {
4721 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4722             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4723             return $stat;
4724             }
4725 0 0       0 }
4726             }
4727             return wantarray ? () : undef;
4728             }
4729              
4730             #
4731             # GB18030 file stat (without parameter)
4732             #
4733 0     0 0 0 sub Egb18030::stat_() {
4734 0 0       0  
    0          
    0          
4735 0         0 my $fh = qualify_to_ref $_;
4736             if (defined fileno $fh) {
4737             return CORE::stat $fh;
4738 0         0 }
4739             elsif (-e $_) {
4740             return CORE::stat _;
4741 0         0 }
4742 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4743 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4744 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4745 0 0       0 if (wantarray) {
4746 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4747             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4748             return @stat;
4749 0         0 }
4750 0 0       0 else {
4751 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4752             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4753             return $stat;
4754             }
4755 0 0       0 }
4756             }
4757             return wantarray ? () : undef;
4758             }
4759              
4760             #
4761             # GB18030 path unlink
4762             #
4763 0 0   0 0 0 sub Egb18030::unlink(@) {
4764              
4765 0         0 local @_ = ($_) unless @_;
4766 0         0  
4767 0 0       0 my $unlink = 0;
    0          
    0          
4768 0         0 for (@_) {
4769             if (CORE::unlink) {
4770             $unlink++;
4771             }
4772             elsif (Egb18030::d($_)) {
4773 0         0 }
4774 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
  0         0  
4775 0 0       0 my @char = /\G (?>$q_char) /oxmsg;
4776 0         0 my $file = join '', map {{'/' => '\\'}->{$_} || $_} @char;
4777             if ($file =~ / \A (?:$q_char)*? [ ] /oxms) {
4778 0         0 $file = qq{"$file"};
4779 0 0       0 }
4780 0 0       0 my $fh = gensym();
4781             if (_open_r($fh, $_)) {
4782             close($fh) or die "Can't close file: $_: $!";
4783 0 0 0     0  
    0          
4784 0         0 # cmd.exe on Windows NT, Windows 2000, Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
4785             if ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
4786             CORE::system 'DEL', '/F', $file, '2>NUL';
4787             }
4788              
4789 0         0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
4790             elsif (qx{ver} =~ /\b(?:Windows 2000)\b/oms) {
4791             CORE::system 'DEL', '/F', $file, '2>NUL';
4792             }
4793              
4794             # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
4795 0         0 # command.com can not "2>NUL"
4796 0         0 else {
4797             CORE::system 'ATTRIB', '-R', $file; # clears Read-only file attribute
4798             CORE::system 'DEL', $file;
4799 0 0       0 }
4800 0 0       0  
4801             if (_open_r($fh, $_)) {
4802             close($fh) or die "Can't close file: $_: $!";
4803 0         0 }
4804             else {
4805             $unlink++;
4806             }
4807             }
4808 0         0 }
4809             }
4810             return $unlink;
4811             }
4812              
4813             #
4814             # GB18030 chdir
4815             #
4816 0 0   0 0 0 sub Egb18030::chdir(;$) {
4817 0         0  
4818             if (@_ == 0) {
4819             return CORE::chdir;
4820 0         0 }
4821              
4822 0 0       0 my($dir) = @_;
4823 0 0       0  
4824 0         0 if (_MSWin32_5Cended_path($dir)) {
4825             if (not Egb18030::d $dir) {
4826             return 0;
4827 0 0 0     0 }
    0          
4828 0         0  
4829             if ($] =~ /^5\.005/oxms) {
4830             return CORE::chdir $dir;
4831 0         0 }
4832 0         0 elsif (($] =~ /^(?:5\.006|5\.008000)/oxms) and ($^O eq 'MSWin32')) {
4833             local $@;
4834             my $chdir = CORE::eval q{
4835             CORE::require 'jacode.pl';
4836              
4837             # P.676 ${^WIDE_SYSTEM_CALLS}
4838             # in Chapter 28: Special Names
4839             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4840              
4841             # P.790 ${^WIDE_SYSTEM_CALLS}
4842             # in Chapter 25: Special Names
4843             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4844              
4845             local ${^WIDE_SYSTEM_CALLS} = 1;
4846 0 0       0 return CORE::chdir jcode::utf8($dir,'sjis');
4847 0         0 };
4848             if (not $@) {
4849             return $chdir;
4850             }
4851             }
4852              
4853             # old idea (Win32 module required)
4854             elsif (0) {
4855             local $@;
4856             my $shortdir = '';
4857             my $chdir = CORE::eval q{
4858             use Win32;
4859             $shortdir = Win32::GetShortPathName($dir);
4860             if ($shortdir ne $dir) {
4861             return CORE::chdir $shortdir;
4862             }
4863             else {
4864             return 0;
4865             }
4866             };
4867             if ($@) {
4868             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4869             while ($char[-1] eq "\x5C") {
4870             pop @char;
4871             }
4872             $dir = join '', @char;
4873             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path), Win32.pm module may help you";
4874             }
4875             elsif ($shortdir eq $dir) {
4876             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4877             while ($char[-1] eq "\x5C") {
4878             pop @char;
4879             }
4880             $dir = join '', @char;
4881             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path)";
4882             }
4883             return $chdir;
4884             }
4885 0         0  
4886             # rejected idea ...
4887             elsif (0) {
4888              
4889             # MSDN SetCurrentDirectory function
4890             # http://msdn.microsoft.com/ja-jp/library/windows/desktop/aa365530(v=vs.85).aspx
4891             #
4892             # Data Execution Prevention (DEP)
4893             # http://vlaurie.com/computers2/Articles/dep.htm
4894             #
4895             # Learning x86 assembler with Perl -- Shibuya.pm#11
4896             # http://developer.cybozu.co.jp/takesako/2009/06/perl-x86-shibuy.html
4897             #
4898             # Introduction to Win32::API programming in Perl
4899             # http://d.hatena.ne.jp/TAKESAKO/20090324/1237879559
4900             #
4901             # DynaLoader - Dynamically load C libraries into Perl code
4902             # http://perldoc.perl.org/DynaLoader.html
4903             #
4904             # Basic knowledge of DynaLoader
4905             # http://blog.64p.org/entry/20090313/1236934042
4906              
4907             if (($] =~ /^5\.006/oxms) and
4908             ($^O eq 'MSWin32') and
4909             ($ENV{'PROCESSOR_ARCHITECTURE'} eq 'x86') and
4910             CORE::eval(q{CORE::require 'Dyna'.'Loader'})
4911             ) {
4912             my $x86 = join('',
4913              
4914             # PUSH Iv
4915             "\x68", pack('P', "$dir\\\0"),
4916              
4917             # MOV eAX, Iv
4918             "\xb8", pack('L',
4919             *{'Dyna'.'Loader::dl_find_symbol'}{'CODE'}->(
4920             *{'Dyna'.'Loader::dl_load_file'}{'CODE'}->("$ENV{'SystemRoot'}\\system32\\kernel32.dll"),
4921             'SetCurrentDirectoryA'
4922             )
4923             ),
4924              
4925             # CALL eAX
4926             "\xff\xd0",
4927              
4928             # RETN
4929             "\xc3",
4930             );
4931             *{'Dyna'.'Loader::dl_install_xsub'}{'CODE'}->('_SetCurrentDirectoryA', unpack('L', pack 'P', $x86));
4932             _SetCurrentDirectoryA();
4933             chomp(my $chdir = qx{chdir});
4934             if (Egb18030::fc($chdir) eq Egb18030::fc($dir)) {
4935             return 1;
4936             }
4937             else {
4938             return 0;
4939             }
4940             }
4941             }
4942              
4943             # COMMAND.COM's unhelpful tips:
4944             # Displays a list of files and subdirectories in a directory.
4945             # http://www.lagmonster.org/docs/DOS7/z-dir.html
4946             #
4947             # Syntax:
4948             #
4949             # DIR [drive:] [path] [filename] [/Switches]
4950             #
4951             # /Z Long file names are not displayed in the file listing
4952             #
4953             # Limitations
4954             # The undocumented /Z switch (no long names) would appear to
4955             # have been not fully developed and has a couple of problems:
4956             #
4957             # 1. It will only work if:
4958             # There is no path specified (ie. for the current directory in
4959             # the current drive)
4960             # The path is specified as the root directory of any drive
4961             # (eg. C:\, D:\, etc.)
4962             # The path is specified as the current directory of any drive
4963             # by using the drive letter only (eg. C:, D:, etc.)
4964             # The path is specified as the parent directory using the ..
4965             # notation (eg. DIR .. /Z)
4966             # Any other syntax results in a "File Not Found" error message.
4967             #
4968             # 2. The /Z switch is compatable with the /S switch to show
4969             # subdirectories (as long as the above rules are followed) and
4970             # all the files are shown with short names only. The
4971             # subdirectories are also shown with short names only. However,
4972             # the header for each subdirectory after the first level gives
4973             # the subdirectory's long name.
4974             #
4975             # 3. The /Z switch is also compatable with the /B switch to give
4976             # a simple list of files with short names only. When used with
4977             # the /S switch as well, all files are listed with their full
4978             # paths. The file names themselves are all in short form, and
4979             # the path of those files in the current directory are in short
4980             # form, but the paths of any files in subdirectories are in
4981 0         0 # long filename form.
4982 0         0  
4983 0         0 my $shortdir = '';
4984 0         0 my $i = 0;
4985 0         0 my @subdir = ();
4986 0 0 0     0 while ($dir =~ / \G ($q_char) /oxgc) {
4987 0         0 my $char = $1;
4988 0         0 if (($char eq '\\') or ($char eq '/')) {
4989 0         0 $i++;
4990             $subdir[$i] = $char;
4991             $i++;
4992 0         0 }
4993             else {
4994             $subdir[$i] .= $char;
4995 0 0 0     0 }
4996 0         0 }
4997             if (($subdir[-1] eq '\\') or ($subdir[-1] eq '/')) {
4998             pop @subdir;
4999             }
5000              
5001             # P.504 PERL5SHELL (Microsoft ports only)
5002             # in Chapter 19: The Command-Line Interface
5003             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5004              
5005             # P.597 PERL5SHELL (Microsoft ports only)
5006             # in Chapter 17: The Command-Line Interface
5007             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5008              
5009 0 0 0     0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
    0          
5010 0         0 # cmd.exe on Windows NT, Windows 2000
5011 0         0 if (qx{ver} =~ /\b(?:Windows NT|Windows 2000)\b/oms) {
  0         0  
5012 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5013             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5014             if (Egb18030::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Egb18030::fc($subdir[-1])) {
5015 0         0  
5016 0         0 # short file name (8dot3name) here-----vv
5017 0         0 my $shortleafdir = CORE::substr $dirx, 39, 8+1+3;
5018 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5019             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5020             last;
5021             }
5022             }
5023             }
5024              
5025             # an idea (not so portable, only Windows 2000 or later)
5026             elsif (0) {
5027             chomp($shortdir = qx{for %I in ("$dir") do \@echo %~sI 2>NUL});
5028             }
5029              
5030 0         0 # cmd.exe on Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
5031 0         0 elsif ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
  0         0  
5032 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5033             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5034             if (Egb18030::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Egb18030::fc($subdir[-1])) {
5035 0         0  
5036 0         0 # short file name (8dot3name) here-----vv
5037 0         0 my $shortleafdir = CORE::substr $dirx, 36, 8+1+3;
5038 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5039             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5040             last;
5041             }
5042             }
5043             }
5044              
5045 0         0 # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
5046 0         0 else {
  0         0  
5047 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad "$dir*"});
5048             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5049             if (Egb18030::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Egb18030::fc($subdir[-1])) {
5050 0         0  
5051 0         0 # short file name (8dot3name) here-----v
5052 0         0 my $shortleafdir = CORE::substr $dirx, 0, 8+1+3;
5053 0         0 CORE::substr($shortleafdir,8,1) = '.';
5054 0         0 $shortleafdir =~ s/ \. [ ]+ \z//oxms;
5055             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5056             last;
5057             }
5058             }
5059 0 0       0 }
    0          
5060 0         0  
5061             if ($shortdir eq '') {
5062             return 0;
5063 0         0 }
5064             elsif (Egb18030::fc($shortdir) eq Egb18030::fc($dir)) {
5065 0         0 return 0;
5066             }
5067             return CORE::chdir $shortdir;
5068 0         0 }
5069             else {
5070             return CORE::chdir $dir;
5071             }
5072             }
5073              
5074             #
5075             # GB18030 chr(0x5C) ended path on MSWin32
5076             #
5077 0 50 33 768   0 sub _MSWin32_5Cended_path {
5078 768 50       5881  
5079 768         4505 if ((@_ >= 1) and ($_[0] ne '')) {
5080 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
5081 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5082             if ($char[-1] =~ / \x5C \z/oxms) {
5083             return 1;
5084             }
5085 0         0 }
5086             }
5087             return undef;
5088             }
5089              
5090             #
5091             # do GB18030 file
5092             #
5093 768     0 0 2085 sub Egb18030::do($) {
5094              
5095 0         0 my($filename) = @_;
5096              
5097             my $realfilename;
5098             my $result;
5099 0         0 ITER_DO:
  0         0  
5100 0 0       0 {
5101 0         0 for my $prefix (@INC) {
5102             if ($^O eq 'MacOS') {
5103             $realfilename = "$prefix$filename";
5104 0         0 }
5105             else {
5106             $realfilename = "$prefix/$filename";
5107 0 0       0 }
5108              
5109 0         0 if (Egb18030::f($realfilename)) {
5110              
5111 0 0       0 my $script = '';
5112 0         0  
5113 0         0 if (Egb18030::e("$realfilename.e")) {
5114 0         0 my $e_mtime = (Egb18030::stat("$realfilename.e"))[9];
5115 0 0 0     0 my $mtime = (Egb18030::stat($realfilename))[9];
5116 0         0 my $module_mtime = (Egb18030::stat(__FILE__))[9];
5117             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5118             Egb18030::unlink "$realfilename.e";
5119             }
5120 0 0       0 }
5121 0         0  
5122 0 0       0 if (Egb18030::e("$realfilename.e")) {
5123 0 0       0 my $fh = gensym();
    0          
5124 0         0 if (_open_r($fh, "$realfilename.e")) {
5125             if ($^O eq 'MacOS') {
5126             CORE::eval q{
5127             CORE::require Mac::Files;
5128             Mac::Files::FSpSetFLock("$realfilename.e");
5129             };
5130             }
5131             elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5132              
5133             # P.419 File Locking
5134             # in Chapter 16: Interprocess Communication
5135             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5136              
5137             # P.524 File Locking
5138             # in Chapter 15: Interprocess Communication
5139             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5140              
5141 0         0 # (and so on)
5142 0 0       0  
5143 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5144             if ($@) {
5145             carp "Can't immediately read-lock the file: $realfilename.e";
5146             }
5147 0         0 }
5148             else {
5149 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5150 0         0 }
5151 0 0       0 local $/ = undef; # slurp mode
5152 0         0 $script = <$fh>;
5153             if ($^O eq 'MacOS') {
5154             CORE::eval q{
5155             CORE::require Mac::Files;
5156             Mac::Files::FSpRstFLock("$realfilename.e");
5157 0 0       0 };
5158             }
5159             close($fh) or die "Can't close file: $realfilename.e: $!";
5160             }
5161 0         0 }
5162 0 0       0 else {
5163 0 0       0 my $fh = gensym();
    0          
5164 0         0 if (_open_r($fh, $realfilename)) {
5165             if ($^O eq 'MacOS') {
5166             CORE::eval q{
5167             CORE::require Mac::Files;
5168             Mac::Files::FSpSetFLock($realfilename);
5169             };
5170 0         0 }
5171 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5172 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5173             if ($@) {
5174             carp "Can't immediately read-lock the file: $realfilename";
5175             }
5176 0         0 }
5177             else {
5178 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5179 0         0 }
5180 0 0       0 local $/ = undef; # slurp mode
5181 0         0 $script = <$fh>;
5182             if ($^O eq 'MacOS') {
5183             CORE::eval q{
5184             CORE::require Mac::Files;
5185             Mac::Files::FSpRstFLock($realfilename);
5186 0 0       0 };
5187             }
5188             close($fh) or die "Can't close file: $realfilename.e: $!";
5189 0 0       0 }
5190 0         0  
5191 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) GB18030 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5192 0         0 CORE::require GB18030;
5193 0 0       0 $script = GB18030::escape_script($script);
5194 0 0       0 my $fh = gensym();
    0          
5195 0         0 open($fh, ">$realfilename.e") or die __FILE__, ": Can't write open file: $realfilename.e\n";
5196             if ($^O eq 'MacOS') {
5197             CORE::eval q{
5198             CORE::require Mac::Files;
5199             Mac::Files::FSpSetFLock("$realfilename.e");
5200             };
5201 0         0 }
5202 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5203 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5204             if ($@) {
5205             carp "Can't immediately write-lock the file: $realfilename.e";
5206             }
5207 0         0 }
5208             else {
5209 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5210 0 0       0 }
5211 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5212 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5213 0         0 print {$fh} $script;
5214             if ($^O eq 'MacOS') {
5215             CORE::eval q{
5216             CORE::require Mac::Files;
5217             Mac::Files::FSpRstFLock("$realfilename.e");
5218 0 0       0 };
5219             }
5220             close($fh) or die "Can't close file: $realfilename.e: $!";
5221             }
5222             }
5223 389     389   16632  
  389         1274  
  389         406937  
  0         0  
5224 0         0 {
5225             no strict;
5226 0         0 $result = scalar CORE::eval $script;
5227             }
5228             last ITER_DO;
5229             }
5230             }
5231 0 0       0 }
    0          
5232 0         0  
5233 0         0 if ($@) {
5234             $INC{$filename} = undef;
5235             return undef;
5236 0         0 }
5237             elsif (not $result) {
5238             return undef;
5239 0         0 }
5240 0         0 else {
5241             $INC{$filename} = $realfilename;
5242             return $result;
5243             }
5244             }
5245              
5246             #
5247             # require GB18030 file
5248             #
5249              
5250             # require
5251             # in Chapter 3: Functions
5252             # of ISBN 1-56592-149-6 Programming Perl, Second Edition.
5253             #
5254             # sub require {
5255             # my($filename) = @_;
5256             # return 1 if $INC{$filename};
5257             # my($realfilename, $result);
5258             # ITER: {
5259             # foreach $prefix (@INC) {
5260             # $realfilename = "$prefix/$filename";
5261             # if (-f $realfilename) {
5262             # $result = CORE::eval `cat $realfilename`;
5263             # last ITER;
5264             # }
5265             # }
5266             # die "Can't find $filename in \@INC";
5267             # }
5268             # die $@ if $@;
5269             # die "$filename did not return true value" unless $result;
5270             # $INC{$filename} = $realfilename;
5271             # return $result;
5272             # }
5273              
5274             # require
5275             # in Chapter 9: perlfunc: Perl builtin functions
5276             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
5277             #
5278             # sub require {
5279             # my($filename) = @_;
5280             # if (exists $INC{$filename}) {
5281             # return 1 if $INC{$filename};
5282             # die "Compilation failed in require";
5283             # }
5284             # my($realfilename, $result);
5285             # ITER: {
5286             # foreach $prefix (@INC) {
5287             # $realfilename = "$prefix/$filename";
5288             # if (-f $realfilename) {
5289             # $INC{$filename} = $realfilename;
5290             # $result = do $realfilename;
5291             # last ITER;
5292             # }
5293             # }
5294             # die "Can't find $filename in \@INC";
5295             # }
5296             # if ($@) {
5297             # $INC{$filename} = undef;
5298             # die $@;
5299             # }
5300             # elsif (!$result) {
5301             # delete $INC{$filename};
5302             # die "$filename did not return true value";
5303             # }
5304             # else {
5305             # return $result;
5306             # }
5307             # }
5308              
5309 0 0   0 0 0 sub Egb18030::require(;$) {
5310              
5311 0 0       0 local $_ = shift if @_;
5312 0 0       0  
5313 0         0 if (exists $INC{$_}) {
5314             return 1 if $INC{$_};
5315             croak "Compilation failed in require: $_";
5316             }
5317              
5318             # jcode.pl
5319             # ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
5320              
5321             # jacode.pl
5322 0 0       0 # http://search.cpan.org/dist/jacode/
5323 0         0  
5324             if (/ \b (?: jcode\.pl | jacode(?>[0-9]*)\.pl ) \z /oxms) {
5325             return CORE::require($_);
5326 0         0 }
5327              
5328             my $realfilename;
5329             my $result;
5330 0         0 ITER_REQUIRE:
  0         0  
5331 0 0       0 {
5332 0         0 for my $prefix (@INC) {
5333             if ($^O eq 'MacOS') {
5334             $realfilename = "$prefix$_";
5335 0         0 }
5336             else {
5337             $realfilename = "$prefix/$_";
5338 0 0       0 }
5339 0         0  
5340             if (Egb18030::f($realfilename)) {
5341 0         0 $INC{$_} = $realfilename;
5342              
5343 0 0       0 my $script = '';
5344 0         0  
5345 0         0 if (Egb18030::e("$realfilename.e")) {
5346 0         0 my $e_mtime = (Egb18030::stat("$realfilename.e"))[9];
5347 0 0 0     0 my $mtime = (Egb18030::stat($realfilename))[9];
5348 0         0 my $module_mtime = (Egb18030::stat(__FILE__))[9];
5349             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5350             Egb18030::unlink "$realfilename.e";
5351             }
5352 0 0       0 }
5353 0         0  
5354 0 0       0 if (Egb18030::e("$realfilename.e")) {
5355 0 0       0 my $fh = gensym();
    0          
5356 0         0 _open_r($fh, "$realfilename.e") or croak "Can't open file: $realfilename.e";
5357             if ($^O eq 'MacOS') {
5358             CORE::eval q{
5359             CORE::require Mac::Files;
5360             Mac::Files::FSpSetFLock("$realfilename.e");
5361             };
5362 0         0 }
5363 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5364 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5365             if ($@) {
5366             carp "Can't immediately read-lock the file: $realfilename.e";
5367             }
5368 0         0 }
5369             else {
5370 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5371 0         0 }
5372 0 0       0 local $/ = undef; # slurp mode
5373 0         0 $script = <$fh>;
5374             if ($^O eq 'MacOS') {
5375             CORE::eval q{
5376             CORE::require Mac::Files;
5377             Mac::Files::FSpRstFLock("$realfilename.e");
5378 0 0       0 };
5379             }
5380             close($fh) or croak "Can't close file: $realfilename: $!";
5381 0         0 }
5382 0 0       0 else {
5383 0 0       0 my $fh = gensym();
    0          
5384 0         0 _open_r($fh, $realfilename) or croak "Can't open file: $realfilename";
5385             if ($^O eq 'MacOS') {
5386             CORE::eval q{
5387             CORE::require Mac::Files;
5388             Mac::Files::FSpSetFLock($realfilename);
5389             };
5390 0         0 }
5391 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5392 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5393             if ($@) {
5394             carp "Can't immediately read-lock the file: $realfilename";
5395             }
5396 0         0 }
5397             else {
5398 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5399 0         0 }
5400 0 0       0 local $/ = undef; # slurp mode
5401 0         0 $script = <$fh>;
5402             if ($^O eq 'MacOS') {
5403             CORE::eval q{
5404             CORE::require Mac::Files;
5405             Mac::Files::FSpRstFLock($realfilename);
5406 0 0       0 };
5407             }
5408 0 0       0 close($fh) or croak "Can't close file: $realfilename: $!";
5409 0         0  
5410 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) GB18030 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5411 0         0 CORE::require GB18030;
5412 0 0       0 $script = GB18030::escape_script($script);
5413 0 0       0 my $fh = gensym();
    0          
5414 0         0 open($fh, ">$realfilename.e") or croak "Can't write open file: $realfilename.e";
5415             if ($^O eq 'MacOS') {
5416             CORE::eval q{
5417             CORE::require Mac::Files;
5418             Mac::Files::FSpSetFLock("$realfilename.e");
5419             };
5420 0         0 }
5421 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5422 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5423             if ($@) {
5424             carp "Can't immediately write-lock the file: $realfilename.e";
5425             }
5426 0         0 }
5427             else {
5428 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5429 0 0       0 }
5430 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5431 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5432 0         0 print {$fh} $script;
5433             if ($^O eq 'MacOS') {
5434             CORE::eval q{
5435             CORE::require Mac::Files;
5436             Mac::Files::FSpRstFLock("$realfilename.e");
5437 0 0       0 };
5438             }
5439             close($fh) or croak "Can't close file: $realfilename: $!";
5440             }
5441             }
5442 389     389   6034  
  389         2281  
  389         458657  
  0         0  
5443 0         0 {
5444             no strict;
5445 0         0 $result = scalar CORE::eval $script;
5446             }
5447             last ITER_REQUIRE;
5448 0         0 }
5449             }
5450             croak "Can't find $_ in \@INC";
5451 0 0       0 }
    0          
5452 0         0  
5453 0         0 if ($@) {
5454             $INC{$_} = undef;
5455             croak $@;
5456 0         0 }
5457 0         0 elsif (not $result) {
5458             delete $INC{$_};
5459             croak "$_ did not return true value";
5460 0         0 }
5461             else {
5462             return $result;
5463             }
5464             }
5465              
5466             #
5467             # GB18030 telldir avoid warning
5468             #
5469 0     768 0 0 sub Egb18030::telldir(*) {
5470              
5471 768         2435 local $^W = 0;
5472              
5473             return CORE::telldir $_[0];
5474             }
5475              
5476             #
5477             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
5478 768 0   0 0 31432 #
5479 0 0 0     0 sub Egb18030::PREMATCH {
5480 0         0 if (defined($&)) {
5481             if (defined($1) and (CORE::substr($&,-CORE::length($1),CORE::length($1)) eq $1)) {
5482             return CORE::substr($&,0,CORE::length($&)-CORE::length($1));
5483 0         0 }
5484             else {
5485             croak 'Use of "$`", $PREMATCH, and ${^PREMATCH} need to /( capture all )/ in regexp';
5486             }
5487 0         0 }
5488             else {
5489 0         0 return '';
5490             }
5491             return $`;
5492             }
5493              
5494             #
5495             # ${^MATCH}, $MATCH, $& the string that matched
5496 0 0   0 0 0 #
5497 0 0       0 sub Egb18030::MATCH {
5498 0         0 if (defined($&)) {
5499             if (defined($1)) {
5500             return $1;
5501 0         0 }
5502             else {
5503             croak 'Use of "$&", $MATCH, and ${^MATCH} need to /( capture all )/ in regexp';
5504             }
5505 0         0 }
5506             else {
5507 0         0 return '';
5508             }
5509             return $&;
5510             }
5511              
5512             #
5513             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
5514 0     0 0 0 #
5515             sub Egb18030::POSTMATCH {
5516             return $';
5517             }
5518              
5519             #
5520             # GB18030 character to order (with parameter)
5521             #
5522 0 0   0 1 0 sub GB18030::ord(;$) {
5523              
5524 0 0       0 local $_ = shift if @_;
5525 0         0  
5526 0         0 if (/\A ($q_char) /oxms) {
5527 0         0 my @ord = unpack 'C*', $1;
5528 0         0 my $ord = 0;
5529             while (my $o = shift @ord) {
5530 0         0 $ord = $ord * 0x100 + $o;
5531             }
5532             return $ord;
5533 0         0 }
5534             else {
5535             return CORE::ord $_;
5536             }
5537             }
5538              
5539             #
5540             # GB18030 character to order (without parameter)
5541             #
5542 0 0   0 0 0 sub GB18030::ord_() {
5543 0         0  
5544 0         0 if (/\A ($q_char) /oxms) {
5545 0         0 my @ord = unpack 'C*', $1;
5546 0         0 my $ord = 0;
5547             while (my $o = shift @ord) {
5548 0         0 $ord = $ord * 0x100 + $o;
5549             }
5550             return $ord;
5551 0         0 }
5552             else {
5553             return CORE::ord $_;
5554             }
5555             }
5556              
5557             #
5558             # GB18030 reverse
5559             #
5560 0 0   0 0 0 sub GB18030::reverse(@) {
5561 0         0  
5562             if (wantarray) {
5563             return CORE::reverse @_;
5564             }
5565             else {
5566              
5567             # One of us once cornered Larry in an elevator and asked him what
5568             # problem he was solving with this, but he looked as far off into
5569             # the distance as he could in an elevator and said, "It seemed like
5570 0         0 # a good idea at the time."
5571              
5572             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
5573             }
5574             }
5575              
5576             #
5577             # GB18030 getc (with parameter, without parameter)
5578             #
5579 0     0 0 0 sub GB18030::getc(;*@) {
5580 0 0       0  
5581 0 0 0     0 my($package) = caller;
5582             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
5583 0         0 croak 'Too many arguments for GB18030::getc' if @_ and not wantarray;
  0         0  
5584 0         0  
5585 0         0 my @length = sort { $a <=> $b } keys %range_tr;
5586 0         0 my $getc = '';
5587 0 0       0 for my $length ($length[0] .. $length[-1]) {
5588 0 0       0 $getc .= CORE::getc($fh);
5589 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
5590             if ($getc =~ /\A ${Egb18030::dot_s} \z/oxms) {
5591             return wantarray ? ($getc,@_) : $getc;
5592             }
5593 0 0       0 }
5594             }
5595             return wantarray ? ($getc,@_) : $getc;
5596             }
5597              
5598             #
5599             # GB18030 length by character
5600             #
5601 0 0   0 1 0 sub GB18030::length(;$) {
5602              
5603 0         0 local $_ = shift if @_;
5604 0         0  
5605             local @_ = /\G ($q_char) /oxmsg;
5606             return scalar @_;
5607             }
5608              
5609             #
5610             # GB18030 substr by character
5611             #
5612             BEGIN {
5613              
5614             # P.232 The lvalue Attribute
5615             # in Chapter 6: Subroutines
5616             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5617              
5618             # P.336 The lvalue Attribute
5619             # in Chapter 7: Subroutines
5620             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5621              
5622             # P.144 8.4 Lvalue subroutines
5623             # in Chapter 8: perlsub: Perl subroutines
5624 389 50 0 389 1 272846 # 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  
5625              
5626             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
5627             # vv----------------------*******
5628             sub GB18030::substr($$;$$) %s {
5629              
5630             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5631              
5632             # If the substring is beyond either end of the string, substr() returns the undefined
5633             # value and produces a warning. When used as an lvalue, specifying a substring that
5634             # is entirely outside the string raises an exception.
5635             # http://perldoc.perl.org/functions/substr.html
5636              
5637             # A return with no argument returns the scalar value undef in scalar context,
5638             # an empty list () in list context, and (naturally) nothing at all in void
5639             # context.
5640              
5641             my $offset = $_[1];
5642             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
5643             return;
5644             }
5645              
5646             # substr($string,$offset,$length,$replacement)
5647             if (@_ == 4) {
5648             my(undef,undef,$length,$replacement) = @_;
5649             my $substr = join '', splice(@char, $offset, $length, $replacement);
5650             $_[0] = join '', @char;
5651              
5652             # return $substr; this doesn't work, don't say "return"
5653             $substr;
5654             }
5655              
5656             # substr($string,$offset,$length)
5657             elsif (@_ == 3) {
5658             my(undef,undef,$length) = @_;
5659             my $octet_offset = 0;
5660             my $octet_length = 0;
5661             if ($offset == 0) {
5662             $octet_offset = 0;
5663             }
5664             elsif ($offset > 0) {
5665             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5666             }
5667             else {
5668             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5669             }
5670             if ($length == 0) {
5671             $octet_length = 0;
5672             }
5673             elsif ($length > 0) {
5674             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
5675             }
5676             else {
5677             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
5678             }
5679             CORE::substr($_[0], $octet_offset, $octet_length);
5680             }
5681              
5682             # substr($string,$offset)
5683             else {
5684             my $octet_offset = 0;
5685             if ($offset == 0) {
5686             $octet_offset = 0;
5687             }
5688             elsif ($offset > 0) {
5689             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5690             }
5691             else {
5692             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5693             }
5694             CORE::substr($_[0], $octet_offset);
5695             }
5696             }
5697             END
5698             }
5699              
5700             #
5701             # GB18030 index by character
5702             #
5703 0     0 1 0 sub GB18030::index($$;$) {
5704 0 0       0  
5705 0         0 my $index;
5706             if (@_ == 3) {
5707             $index = Egb18030::index($_[0], $_[1], CORE::length(GB18030::substr($_[0], 0, $_[2])));
5708 0         0 }
5709             else {
5710             $index = Egb18030::index($_[0], $_[1]);
5711 0 0       0 }
5712 0         0  
5713             if ($index == -1) {
5714             return -1;
5715 0         0 }
5716             else {
5717             return GB18030::length(CORE::substr $_[0], 0, $index);
5718             }
5719             }
5720              
5721             #
5722             # GB18030 rindex by character
5723             #
5724 0     0 1 0 sub GB18030::rindex($$;$) {
5725 0 0       0  
5726 0         0 my $rindex;
5727             if (@_ == 3) {
5728             $rindex = Egb18030::rindex($_[0], $_[1], CORE::length(GB18030::substr($_[0], 0, $_[2])));
5729 0         0 }
5730             else {
5731             $rindex = Egb18030::rindex($_[0], $_[1]);
5732 0 0       0 }
5733 0         0  
5734             if ($rindex == -1) {
5735             return -1;
5736 0         0 }
5737             else {
5738             return GB18030::length(CORE::substr $_[0], 0, $rindex);
5739             }
5740             }
5741              
5742 389     389   3226 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  389         1090  
  389         59946  
5743             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
5744             use vars qw($slash); $slash = 'm//';
5745              
5746             # ord() to ord() or GB18030::ord()
5747             my $function_ord = 'ord';
5748              
5749             # ord to ord or GB18030::ord_
5750             my $function_ord_ = 'ord';
5751              
5752             # reverse to reverse or GB18030::reverse
5753             my $function_reverse = 'reverse';
5754              
5755             # getc to getc or GB18030::getc
5756             my $function_getc = 'getc';
5757              
5758             # P.1023 Appendix W.9 Multibyte Anchoring
5759             # of ISBN 1-56592-224-7 CJKV Information Processing
5760              
5761             my $anchor = '';
5762 389     389   5166 $anchor = q{${Egb18030::anchor}};
  389     0   769  
  389         24863139  
5763              
5764             use vars qw($nest);
5765              
5766             # regexp of nested parens in qqXX
5767              
5768             # P.340 Matching Nested Constructs with Embedded Code
5769             # in Chapter 7: Perl
5770             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5771              
5772             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
5773             [^\x81-\xFE\\()] |
5774             \( (?{$nest++}) |
5775             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5776             [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5777             \\ [^\x81-\xFEc] |
5778             \\c[\x40-\x5F] |
5779             \\ [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5780             [\x00-\xFF]
5781             }xms;
5782              
5783             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
5784             [^\x81-\xFE\\{}] |
5785             \{ (?{$nest++}) |
5786             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5787             [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5788             \\ [^\x81-\xFEc] |
5789             \\c[\x40-\x5F] |
5790             \\ [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5791             [\x00-\xFF]
5792             }xms;
5793              
5794             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
5795             [^\x81-\xFE\\\[\]] |
5796             \[ (?{$nest++}) |
5797             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5798             [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5799             \\ [^\x81-\xFEc] |
5800             \\c[\x40-\x5F] |
5801             \\ [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5802             [\x00-\xFF]
5803             }xms;
5804              
5805             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
5806             [^\x81-\xFE\\<>] |
5807             \< (?{$nest++}) |
5808             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5809             [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5810             \\ [^\x81-\xFEc] |
5811             \\c[\x40-\x5F] |
5812             \\ [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5813             [\x00-\xFF]
5814             }xms;
5815              
5816             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
5817             (?: ::)? (?:
5818             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5819             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5820             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5821             ))
5822             }xms;
5823              
5824             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
5825             (?: ::)? (?:
5826             (?>[0-9]+) |
5827             [^\x81-\xFEa-zA-Z_0-9\[\]] |
5828             ^[A-Z] |
5829             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5830             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5831             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5832             ))
5833             }xms;
5834              
5835             my $qq_substr = qr{(?> Char::substr | GB18030::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
5836             }xms;
5837              
5838             # regexp of nested parens in qXX
5839             my $q_paren = qr{(?{local $nest=0}) (?>(?:
5840             [^\x81-\xFE()] |
5841             [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5842             \( (?{$nest++}) |
5843             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5844             [\x00-\xFF]
5845             }xms;
5846              
5847             my $q_brace = qr{(?{local $nest=0}) (?>(?:
5848             [^\x81-\xFE\{\}] |
5849             [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5850             \{ (?{$nest++}) |
5851             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5852             [\x00-\xFF]
5853             }xms;
5854              
5855             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
5856             [^\x81-\xFE\[\]] |
5857             [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5858             \[ (?{$nest++}) |
5859             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5860             [\x00-\xFF]
5861             }xms;
5862              
5863             my $q_angle = qr{(?{local $nest=0}) (?>(?:
5864             [^\x81-\xFE<>] |
5865             [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
5866             \< (?{$nest++}) |
5867             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5868             [\x00-\xFF]
5869             }xms;
5870              
5871             my $matched = '';
5872             my $s_matched = '';
5873             $matched = q{$Egb18030::matched};
5874             $s_matched = q{ Egb18030::s_matched();};
5875              
5876             my $tr_variable = ''; # variable of tr///
5877             my $sub_variable = ''; # variable of s///
5878             my $bind_operator = ''; # =~ or !~
5879              
5880             my @heredoc = (); # here document
5881             my @heredoc_delimiter = ();
5882             my $here_script = ''; # here script
5883              
5884             #
5885             # escape GB18030 script
5886 0 50   384 0 0 #
5887             sub GB18030::escape(;$) {
5888             local($_) = $_[0] if @_;
5889              
5890             # P.359 The Study Function
5891             # in Chapter 7: Perl
5892 384         1536 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5893              
5894             study $_; # Yes, I studied study yesterday.
5895              
5896             # while all script
5897              
5898             # 6.14. Matching from Where the Last Pattern Left Off
5899             # in Chapter 6. Pattern Matching
5900             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
5901             # (and so on)
5902              
5903             # one member of Tag-team
5904             #
5905             # P.128 Start of match (or end of previous match): \G
5906             # P.130 Advanced Use of \G with Perl
5907             # in Chapter 3: Overview of Regular Expression Features and Flavors
5908             # P.255 Use leading anchors
5909             # P.256 Expose ^ and \G at the front expressions
5910             # in Chapter 6: Crafting an Efficient Expression
5911             # P.315 "Tag-team" matching with /gc
5912             # in Chapter 7: Perl
5913 384         937 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5914 384         703  
5915 384         1651 my $e_script = '';
5916             while (not /\G \z/oxgc) { # member
5917             $e_script .= GB18030::escape_token();
5918 189679         374817 }
5919              
5920             return $e_script;
5921             }
5922              
5923             #
5924             # escape GB18030 token of script
5925             #
5926             sub GB18030::escape_token {
5927              
5928 384     189679 0 6374 # \n output here document
5929              
5930             my $ignore_modules = join('|', qw(
5931             utf8
5932             bytes
5933             charnames
5934             I18N::Japanese
5935             I18N::Collate
5936             I18N::JExt
5937             File::DosGlob
5938             Wild
5939             Wildcard
5940             Japanese
5941             ));
5942              
5943             # another member of Tag-team
5944             #
5945             # P.315 "Tag-team" matching with /gc
5946             # in Chapter 7: Perl
5947 189679 100 100     254539 # 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          
5948 189679         16355842  
5949 31714 100       42496 if (/\G ( \n ) /oxgc) { # another member (and so on)
5950 31714         64261 my $heredoc = '';
5951             if (scalar(@heredoc_delimiter) >= 1) {
5952 203         464 $slash = 'm//';
5953 203         421  
5954             $heredoc = join '', @heredoc;
5955             @heredoc = ();
5956 203         509  
5957 203         636 # skip here document
5958             for my $heredoc_delimiter (@heredoc_delimiter) {
5959 211         1406 /\G .*? \n $heredoc_delimiter \n/xmsgc;
5960             }
5961 203         386 @heredoc_delimiter = ();
5962              
5963 203         307 $here_script = '';
5964             }
5965             return "\n" . $heredoc;
5966             }
5967 31714         115783  
5968             # ignore space, comment
5969             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
5970              
5971             # if (, elsif (, unless (, while (, until (, given (, and when (
5972              
5973             # given, when
5974              
5975             # P.225 The given Statement
5976             # in Chapter 15: Smart Matching and given-when
5977             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5978              
5979             # P.133 The given Statement
5980             # in Chapter 4: Statements and Declarations
5981             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5982 43291         151790  
5983 3802         6370 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
5984             $slash = 'm//';
5985             return $1;
5986             }
5987              
5988             # scalar variable ($scalar = ...) =~ tr///;
5989             # scalar variable ($scalar = ...) =~ s///;
5990              
5991             # state
5992              
5993             # P.68 Persistent, Private Variables
5994             # in Chapter 4: Subroutines
5995             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5996              
5997             # P.160 Persistent Lexically Scoped Variables: state
5998             # in Chapter 4: Statements and Declarations
5999             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6000              
6001             # (and so on)
6002 3802         12226  
6003             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
6004 187 50       504 my $e_string = e_string($1);
    50          
6005 187         7919  
6006 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6007 0         0 $tr_variable = $e_string . e_string($1);
6008 0         0 $bind_operator = $2;
6009             $slash = 'm//';
6010             return '';
6011 0         0 }
6012 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6013 0         0 $sub_variable = $e_string . e_string($1);
6014 0         0 $bind_operator = $2;
6015             $slash = 'm//';
6016             return '';
6017 0         0 }
6018 187         495 else {
6019             $slash = 'div';
6020             return $e_string;
6021             }
6022             }
6023              
6024 187         759 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egb18030::PREMATCH()
6025 4         9 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
6026             $slash = 'div';
6027             return q{Egb18030::PREMATCH()};
6028             }
6029              
6030 4         13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egb18030::MATCH()
6031 28         59 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
6032             $slash = 'div';
6033             return q{Egb18030::MATCH()};
6034             }
6035              
6036 28         80 # $', ${'} --> $', ${'}
6037 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
6038             $slash = 'div';
6039             return $1;
6040             }
6041              
6042 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egb18030::POSTMATCH()
6043 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
6044             $slash = 'div';
6045             return q{Egb18030::POSTMATCH()};
6046             }
6047              
6048             # scalar variable $scalar =~ tr///;
6049             # scalar variable $scalar =~ s///;
6050             # substr() =~ tr///;
6051 3         9 # substr() =~ s///;
6052             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
6053 3043 100       7339 my $scalar = e_string($1);
    100          
6054 3043         12950  
6055 9         17 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6056 9         16 $tr_variable = $scalar;
6057 9         14 $bind_operator = $1;
6058             $slash = 'm//';
6059             return '';
6060 9         24 }
6061 255         448 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6062 255         701 $sub_variable = $scalar;
6063 255         380 $bind_operator = $1;
6064             $slash = 'm//';
6065             return '';
6066 255         752 }
6067 2779         5056 else {
6068             $slash = 'div';
6069             return $scalar;
6070             }
6071             }
6072              
6073 2779         19968 # end of statement
6074             elsif (/\G ( [,;] ) /oxgc) {
6075             $slash = 'm//';
6076 12417         21610  
6077             # clear tr/// variable
6078             $tr_variable = '';
6079 12417         15051  
6080             # clear s/// variable
6081 12417         14879 $sub_variable = '';
6082              
6083 12417         44971 $bind_operator = '';
6084              
6085             return $1;
6086             }
6087              
6088 12417         61228 # bareword
6089             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
6090             return $1;
6091             }
6092              
6093 0         0 # $0 --> $0
6094 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
6095             $slash = 'div';
6096             return $1;
6097 2         7 }
6098 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
6099             $slash = 'div';
6100             return $1;
6101             }
6102              
6103 0         0 # $$ --> $$
6104 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
6105             $slash = 'div';
6106             return $1;
6107             }
6108              
6109             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6110 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
6111 221         422 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
6112             $slash = 'div';
6113             return e_capture($1);
6114 221         641 }
6115 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
6116             $slash = 'div';
6117             return e_capture($1);
6118             }
6119              
6120 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6121 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
6122             $slash = 'div';
6123             return e_capture($1.'->'.$2);
6124             }
6125              
6126 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6127 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
6128             $slash = 'div';
6129             return e_capture($1.'->'.$2);
6130             }
6131              
6132 0         0 # $$foo
6133 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
6134             $slash = 'div';
6135             return e_capture($1);
6136             }
6137              
6138 0         0 # ${ foo }
6139 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
6140             $slash = 'div';
6141             return '${' . $1 . '}';
6142             }
6143              
6144 0         0 # ${ ... }
6145 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
6146             $slash = 'div';
6147             return e_capture($1);
6148             }
6149              
6150             # variable or function
6151 0         0 # $ @ % & * $ #
6152 605         1025 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) {
6153             $slash = 'div';
6154             return $1;
6155             }
6156             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
6157 605         1934 # $ @ # \ ' " / ? ( ) [ ] < >
6158 103         207 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
6159             $slash = 'div';
6160             return $1;
6161             }
6162              
6163 103         365 # while ()
6164             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
6165             return $1;
6166             }
6167              
6168             # while () --- glob
6169              
6170             # avoid "Error: Runtime exception" of perl version 5.005_03
6171 0         0  
6172             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])+?) > (?>\s*) \) \b /oxgc) {
6173             return 'while ($_ = Egb18030::glob("' . $1 . '"))';
6174             }
6175              
6176 0         0 # while (glob)
6177             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
6178             return 'while ($_ = Egb18030::glob_)';
6179             }
6180              
6181 0         0 # while (glob(WILDCARD))
6182             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
6183             return 'while ($_ = Egb18030::glob';
6184             }
6185 0         0  
  482         1375  
6186             # doit if, doit unless, doit while, doit until, doit for, doit when
6187             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
6188 482         2142  
  19         34  
6189 19         86 # subroutines of package Egb18030
  0         0  
6190 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         18  
6191 13         34 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
6192 0         0 elsif (/\G \b GB18030::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         175  
6193 114         316 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         3  
6194 2         7 elsif (/\G \b GB18030::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval GB18030::escape'; }
  2         4  
6195 2         55 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
6196 2         8 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::chop'; }
  0         0  
6197 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         5  
6198 2         6 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  2         4  
6199 2         6 elsif (/\G \b GB18030::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'GB18030::index'; }
  2         5  
6200 2         7 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::index'; }
  0         0  
6201 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         4  
6202 2         5 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  2         3  
6203 2         7 elsif (/\G \b GB18030::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'GB18030::rindex'; }
  1         2  
6204 1         5 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::rindex'; }
  0         0  
6205 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egb18030::lc'; }
  0         0  
6206 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egb18030::lcfirst'; }
  0         0  
6207 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egb18030::uc'; }
  3         4  
6208             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egb18030::ucfirst'; }
6209             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egb18030::fc'; }
6210              
6211             # stacked file test operators
6212              
6213             # P.179 File Test Operators
6214             # in Chapter 12: File Tests
6215             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6216              
6217             # P.106 Named Unary and File Test Operators
6218             # in Chapter 3: Unary and Binary Operators
6219             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6220              
6221             # (and so on)
6222 3         10  
  0         0  
6223 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6224 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6225 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6226 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6227 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6228 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  1         3  
6229             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6230             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6231 1         6  
  5         12  
6232 5         24 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6233 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6234 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6235 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6236 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6237 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  1         3  
6238             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6239             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6240 1         9  
  0         0  
6241 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6242 0         0 { $slash = 'm//'; return "Egb18030::filetest(qw($1),$2)"; }
  0         0  
6243 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1),$2)"; }
  0         0  
6244             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $slash = 'm//'; return "Egb18030::filetest qw($1),"; }
6245 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Egb18030::filetest(qw($1),$2)"; }
  0         0  
6246 0         0  
  0         0  
6247 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6248 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6249 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6250 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6251 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  2         6  
6252             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
6253 2         11 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  103         194  
6254 103         322  
  0         0  
6255 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6256 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6257 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6258 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6259 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  2         8  
6260             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6261             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6262 2         37  
  6         13  
6263 6         30 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6264 0         0 { $slash = 'm//'; return "Egb18030::$1($2)"; }
  0         0  
6265 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Egb18030::$1($2)"; }
  50         87  
6266 50         240 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return "Egb18030::$1"; }
  2         5  
6267 2         10 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Egb18030::$1(::"."$2)"; }
  1         3  
6268 1         4 elsif (/\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-t $2"; }
  3         8  
6269             elsif (/\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egb18030::lstat'; }
6270             elsif (/\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egb18030::stat'; }
6271 3         11  
  0         0  
6272 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
6273 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
6274 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6275 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6276 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6277 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6278             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
6279 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  
6280 0         0  
  0         0  
6281 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
6282 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6283 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6284 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6285 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6286             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6287             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6288 0         0  
  0         0  
6289 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6290 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
6291 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
6292             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
6293 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         5  
6294 2         7  
  2         5  
6295 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         78  
6296 36         121 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
6297 2         7 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egb18030::chr'; }
  2         6  
6298 2         7 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  8         115  
6299 8         47 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
6300 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Egb18030::glob'; }
  0         0  
6301 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::lc_'; }
  0         0  
6302 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::lcfirst_'; }
  0         0  
6303 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::uc_'; }
  0         0  
6304 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::ucfirst_'; }
  0         0  
6305 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::fc_'; }
  0         0  
6306             elsif (/\G \b lstat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::lstat_'; }
6307 0         0 elsif (/\G \b stat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::stat_'; }
  0         0  
6308             elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
6309 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Egb18030::filetest_(qw($1))"; }
  0         0  
6310             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC])
6311 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Egb18030::${1}_"; }
  0         0  
6312              
6313 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
6314 0         0  
  0         0  
6315 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
6316 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
6317 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::chr_'; }
  2         6  
6318 2         8 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
6319 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  4         13  
6320 4         16 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::glob_'; }
  8         26  
6321 8         40 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  2         7  
6322 2         13 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0         0  
6323 0         0 elsif (/\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Egb18030::opendir$1*"; }
  87         524  
6324             elsif (/\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Egb18030::opendir$1*"; }
6325             elsif (/\G \b unlink \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Egb18030::unlink'; }
6326              
6327 87         384 # chdir
6328             elsif (/\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
6329 3         9 $slash = 'm//';
6330              
6331 3         5 my $e = 'Egb18030::chdir';
6332 3         11  
6333             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6334             $e .= $1;
6335             }
6336 3 50       13  
  3 100       279  
    50          
    50          
    50          
    0          
6337             # end of chdir
6338             if (/\G (?= [,;\)\}\]] ) /oxgc) { return $e; }
6339 0         0  
6340             # chdir scalar value
6341             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return $e . e_string($1); }
6342              
6343 1 0       4 # chdir qq//
  0         0  
6344             elsif (/\G \b (qq) \b /oxgc) {
6345 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq# # --> qr # #
6346 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6347 0         0 while (not /\G \z/oxgc) {
6348 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6349 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq ( ) --> qr ( )
6350 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq { } --> qr { }
6351 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq [ ] --> qr [ ]
6352 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq < > --> qr < >
6353             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq','{','}',$2); } # qq | | --> qr { }
6354 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq * * --> qr * *
6355             }
6356             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6357             }
6358             }
6359              
6360 0 0       0 # chdir q//
  0         0  
6361             elsif (/\G \b (q) \b /oxgc) {
6362 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q# # --> qr # #
6363 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6364 0         0 while (not /\G \z/oxgc) {
6365 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6366 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q ( ) --> qr ( )
6367 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q { } --> qr { }
6368 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q [ ] --> qr [ ]
6369 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q < > --> qr < >
6370             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q','{','}',$2); } # q | | --> qr { }
6371 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q * * --> qr * *
6372             }
6373             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6374             }
6375             }
6376              
6377 0         0 # chdir ''
6378 2         6 elsif (/\G (\') /oxgc) {
6379 2 50       7 my $q_string = '';
  13 50       75  
    100          
    50          
6380 0         0 while (not /\G \z/oxgc) {
6381 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6382 2         8 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
6383             elsif (/\G \' /oxgc) { return $e . e_chdir_q('',"'","'",$q_string); }
6384 11         25 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6385             }
6386             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6387             }
6388              
6389 0         0 # chdir ""
6390 0         0 elsif (/\G (\") /oxgc) {
6391 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6392 0         0 while (not /\G \z/oxgc) {
6393 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6394 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
6395             elsif (/\G \" /oxgc) { return $e . e_chdir('','"','"',$qq_string); }
6396 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6397             }
6398             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6399             }
6400             }
6401              
6402 0         0 # split
6403             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
6404 419         978 $slash = 'm//';
6405 419         714  
6406 419         1581 my $e = '';
6407             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6408             $e .= $1;
6409             }
6410 416 100       1755  
  419 100       19974  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
6411             # end of split
6412             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Egb18030::split' . $e; }
6413 3         15  
6414             # split scalar value
6415             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Egb18030::split' . $e . e_string($1); }
6416 1         6  
6417 0         0 # split literal space
6418 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Egb18030::split' . $e . qq {qq$1 $2}; }
6419 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Egb18030::split' . $e . qq{$1qq$2 $3}; }
6420 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Egb18030::split' . $e . qq{$1qq$2 $3}; }
6421 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Egb18030::split' . $e . qq{$1qq$2 $3}; }
6422 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Egb18030::split' . $e . qq{$1qq$2 $3}; }
6423 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Egb18030::split' . $e . qq{$1qq$2 $3}; }
6424 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Egb18030::split' . $e . qq {q$1 $2}; }
6425 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Egb18030::split' . $e . qq {$1q$2 $3}; }
6426 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Egb18030::split' . $e . qq {$1q$2 $3}; }
6427 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Egb18030::split' . $e . qq {$1q$2 $3}; }
6428 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Egb18030::split' . $e . qq {$1q$2 $3}; }
6429 16         76 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Egb18030::split' . $e . qq {$1q$2 $3}; }
6430             elsif (/\G ' [ ] ' /oxgc) { return 'Egb18030::split' . $e . qq {' '}; }
6431             elsif (/\G " [ ] " /oxgc) { return 'Egb18030::split' . $e . qq {" "}; }
6432              
6433 2 0       11 # split qq//
  0         0  
6434             elsif (/\G \b (qq) \b /oxgc) {
6435 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
6436 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6437 0         0 while (not /\G \z/oxgc) {
6438 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6439 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
6440 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
6441 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
6442 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
6443             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
6444 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
6445             }
6446             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6447             }
6448             }
6449              
6450 0 50       0 # split qr//
  124         949  
6451             elsif (/\G \b (qr) \b /oxgc) {
6452 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
6453 124 50       397 else {
  124 50       9113  
    50          
    50          
    50          
    100          
    50          
    50          
6454 0         0 while (not /\G \z/oxgc) {
6455 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6456 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
6457 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
6458 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
6459 56         190 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
6460 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
6461             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
6462 68         488 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
6463             }
6464             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6465             }
6466             }
6467              
6468 0 0       0 # split q//
  0         0  
6469             elsif (/\G \b (q) \b /oxgc) {
6470 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
6471 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6472 0         0 while (not /\G \z/oxgc) {
6473 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6474 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
6475 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
6476 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
6477 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
6478             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
6479 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
6480             }
6481             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6482             }
6483             }
6484              
6485 0 50       0 # split m//
  136         1059  
6486             elsif (/\G \b (m) \b /oxgc) {
6487 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
6488 136 50       350 else {
  136 50       7933  
    50          
    50          
    50          
    100          
    50          
    50          
6489 0         0 while (not /\G \z/oxgc) {
6490 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6491 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
6492 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
6493 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
6494 56         226 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
6495 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
6496             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
6497 80         437 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
6498             }
6499             die __FILE__, ": Search pattern not terminated\n";
6500             }
6501             }
6502              
6503 0         0 # split ''
6504 0         0 elsif (/\G (\') /oxgc) {
6505 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6506 0         0 while (not /\G \z/oxgc) {
6507 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6508 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
6509             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
6510 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6511             }
6512             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6513             }
6514              
6515 0         0 # split ""
6516 0         0 elsif (/\G (\") /oxgc) {
6517 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6518 0         0 while (not /\G \z/oxgc) {
6519 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6520 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
6521             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
6522 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6523             }
6524             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6525             }
6526              
6527 0         0 # split //
6528 137         303 elsif (/\G (\/) /oxgc) {
6529 137 50       445 my $regexp = '';
  582 50       3228  
    100          
    50          
6530 0         0 while (not /\G \z/oxgc) {
6531 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
6532 137         686 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
6533             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
6534 445         996 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
6535             }
6536             die __FILE__, ": Search pattern not terminated\n";
6537             }
6538             }
6539              
6540             # tr/// or y///
6541              
6542             # about [cdsrbB]* (/B modifier)
6543             #
6544             # P.559 appendix C
6545             # of ISBN 4-89052-384-7 Programming perl
6546             # (Japanese title is: Perl puroguramingu)
6547 0         0  
6548             elsif (/\G \b ( tr | y ) \b /oxgc) {
6549             my $ope = $1;
6550 11 50       27  
6551 11         180 # $1 $2 $3 $4 $5 $6
6552 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
6553             my @tr = ($tr_variable,$2);
6554             return e_tr(@tr,'',$4,$6);
6555 0         0 }
6556 11         21 else {
6557 11 50       29 my $e = '';
  11 50       885  
    50          
    50          
    50          
    50          
6558             while (not /\G \z/oxgc) {
6559 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6560 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6561 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6562 0         0 while (not /\G \z/oxgc) {
6563 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6564 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
6565 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
6566 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
6567             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
6568 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
6569             }
6570             die __FILE__, ": Transliteration replacement not terminated\n";
6571 0         0 }
6572 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6573 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6574 0         0 while (not /\G \z/oxgc) {
6575 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6576 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
6577 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
6578 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
6579             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
6580 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
6581             }
6582             die __FILE__, ": Transliteration replacement not terminated\n";
6583 0         0 }
6584 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6585 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6586 0         0 while (not /\G \z/oxgc) {
6587 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6588 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
6589 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
6590 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
6591             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
6592 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
6593             }
6594             die __FILE__, ": Transliteration replacement not terminated\n";
6595 0         0 }
6596 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6597 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6598 0         0 while (not /\G \z/oxgc) {
6599 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6600 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
6601 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
6602 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
6603             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
6604 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
6605             }
6606             die __FILE__, ": Transliteration replacement not terminated\n";
6607             }
6608 0         0 # $1 $2 $3 $4 $5 $6
6609 11         42 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
6610             my @tr = ($tr_variable,$2);
6611             return e_tr(@tr,'',$4,$6);
6612 11         32 }
6613             }
6614             die __FILE__, ": Transliteration pattern not terminated\n";
6615             }
6616             }
6617              
6618 0         0 # qq//
6619             elsif (/\G \b (qq) \b /oxgc) {
6620             my $ope = $1;
6621 5927 100       17213  
6622 5927         12733 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
6623 40         56 if (/\G (\#) /oxgc) { # qq# #
6624 40 100       87 my $qq_string = '';
  1948 50       5507  
    100          
    50          
6625 80         162 while (not /\G \z/oxgc) {
6626 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6627 40         95 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
6628             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
6629 1828         3302 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6630             }
6631             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6632             }
6633 0         0  
6634 5887         8440 else {
6635 5887 50       14799 my $e = '';
  5887 50       24971  
    100          
    50          
    100          
    50          
6636             while (not /\G \z/oxgc) {
6637             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6638              
6639 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
6640 0         0 elsif (/\G (\() /oxgc) { # qq ( )
6641 0         0 my $qq_string = '';
6642 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6643 0         0 while (not /\G \z/oxgc) {
6644 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6645             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
6646 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6647 0         0 elsif (/\G (\)) /oxgc) {
6648             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
6649 0         0 else { $qq_string .= $1; }
6650             }
6651 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6652             }
6653             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6654             }
6655              
6656 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
6657 5805         8407 elsif (/\G (\{) /oxgc) { # qq { }
6658 5805         8279 my $qq_string = '';
6659 5805 100       12610 local $nest = 1;
  246837 50       838067  
    100          
    100          
    50          
6660 720         1350 while (not /\G \z/oxgc) {
6661 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1384         1941  
6662             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
6663 1384 100       2305 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  7189         11738  
6664 5805         14860 elsif (/\G (\}) /oxgc) {
6665             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
6666 1384         2670 else { $qq_string .= $1; }
6667             }
6668 237544         508215 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6669             }
6670             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6671             }
6672              
6673 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
6674 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
6675 0         0 my $qq_string = '';
6676 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6677 0         0 while (not /\G \z/oxgc) {
6678 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6679             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
6680 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6681 0         0 elsif (/\G (\]) /oxgc) {
6682             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
6683 0         0 else { $qq_string .= $1; }
6684             }
6685 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6686             }
6687             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6688             }
6689              
6690 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
6691 62         108 elsif (/\G (\<) /oxgc) { # qq < >
6692 62         104 my $qq_string = '';
6693 62 100       168 local $nest = 1;
  2040 50       7374  
    100          
    100          
    50          
6694 22         50 while (not /\G \z/oxgc) {
6695 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  2         5  
6696             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
6697 2 100       3 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  64         154  
6698 62         162 elsif (/\G (\>) /oxgc) {
6699             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
6700 2         4 else { $qq_string .= $1; }
6701             }
6702 1952         3760 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6703             }
6704             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6705             }
6706              
6707 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
6708 20         33 elsif (/\G (\S) /oxgc) { # qq * *
6709 20         23 my $delimiter = $1;
6710 20 50       39 my $qq_string = '';
  840 50       2320  
    100          
    50          
6711 0         0 while (not /\G \z/oxgc) {
6712 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6713 20         42 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
6714             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
6715 820         1493 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6716             }
6717             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6718 0         0 }
6719             }
6720             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6721             }
6722             }
6723              
6724 0         0 # qr//
6725 184 50       486 elsif (/\G \b (qr) \b /oxgc) {
6726 184         917 my $ope = $1;
6727             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
6728             return e_qr($ope,$1,$3,$2,$4);
6729 0         0 }
6730 184         268 else {
6731 184 50       2536 my $e = '';
  184 50       19044  
    100          
    50          
    50          
    100          
    50          
    50          
6732 0         0 while (not /\G \z/oxgc) {
6733 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6734 1         5 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
6735 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
6736 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
6737 76         208 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
6738 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
6739             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
6740 107         312 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
6741             }
6742             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6743             }
6744             }
6745              
6746 0         0 # qw//
6747 34 50       154 elsif (/\G \b (qw) \b /oxgc) {
6748 34         124 my $ope = $1;
6749             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
6750             return e_qw($ope,$1,$3,$2);
6751 0         0 }
6752 34         69 else {
6753 34 50       2234 my $e = '';
  34 50       234  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6754             while (not /\G \z/oxgc) {
6755 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6756 34         148  
6757             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6758 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6759 0         0  
6760             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6761 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6762 0         0  
6763             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6764 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6765 0         0  
6766             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6767 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6768 0         0  
6769             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6770 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6771             }
6772             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6773             }
6774             }
6775              
6776 0         0 # qx//
6777 3 50       10 elsif (/\G \b (qx) \b /oxgc) {
6778 3         85 my $ope = $1;
6779             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
6780             return e_qq($ope,$1,$3,$2);
6781 0         0 }
6782 3         9 else {
6783 3 50       14 my $e = '';
  3 50       436  
    100          
    50          
    50          
    50          
    50          
6784 0         0 while (not /\G \z/oxgc) {
6785 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6786 2         7 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
6787 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
6788 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
6789 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
6790             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
6791 1         4 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
6792             }
6793             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6794             }
6795             }
6796              
6797 0         0 # q//
6798             elsif (/\G \b (q) \b /oxgc) {
6799             my $ope = $1;
6800              
6801             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
6802              
6803             # avoid "Error: Runtime exception" of perl version 5.005_03
6804 606 50       2299 # (and so on)
6805 606         2018  
6806 0         0 if (/\G (\#) /oxgc) { # q# #
6807 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6808 0         0 while (not /\G \z/oxgc) {
6809 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6810 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
6811             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
6812 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6813             }
6814             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6815             }
6816 0         0  
6817 606         1209 else {
6818 606 50       2255 my $e = '';
  606 100       3984  
    100          
    50          
    100          
    50          
6819             while (not /\G \z/oxgc) {
6820             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6821              
6822 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
6823 1         2 elsif (/\G (\() /oxgc) { # q ( )
6824 1         2 my $q_string = '';
6825 1 50       3 local $nest = 1;
  7 50       53  
    50          
    50          
    100          
    50          
6826 0         0 while (not /\G \z/oxgc) {
6827 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6828 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
6829             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
6830 0 50       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  1         2  
6831 1         3 elsif (/\G (\)) /oxgc) {
6832             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
6833 0         0 else { $q_string .= $1; }
6834             }
6835 6         15 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6836             }
6837             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6838             }
6839              
6840 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
6841 599         1313 elsif (/\G (\{) /oxgc) { # q { }
6842 599         1182 my $q_string = '';
6843 599 50       2127 local $nest = 1;
  8241 50       41233  
    50          
    100          
    100          
    50          
6844 0         0 while (not /\G \z/oxgc) {
6845 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6846 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  114         191  
6847             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
6848 114 100       205 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  713         1658  
6849 599         2098 elsif (/\G (\}) /oxgc) {
6850             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
6851 114         235 else { $q_string .= $1; }
6852             }
6853 7414         15897 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6854             }
6855             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6856             }
6857              
6858 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
6859 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
6860 0         0 my $q_string = '';
6861 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
6862 0         0 while (not /\G \z/oxgc) {
6863 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6864 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
6865             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
6866 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
6867 0         0 elsif (/\G (\]) /oxgc) {
6868             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
6869 0         0 else { $q_string .= $1; }
6870             }
6871 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6872             }
6873             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6874             }
6875              
6876 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
6877 5         13 elsif (/\G (\<) /oxgc) { # q < >
6878 5         11 my $q_string = '';
6879 5 50       18 local $nest = 1;
  82 50       463  
    50          
    50          
    100          
    50          
6880 0         0 while (not /\G \z/oxgc) {
6881 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6882 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
6883             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
6884 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         14  
6885 5         18 elsif (/\G (\>) /oxgc) {
6886             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
6887 0         0 else { $q_string .= $1; }
6888             }
6889 77         166 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6890             }
6891             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6892             }
6893              
6894 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
6895 1         3 elsif (/\G (\S) /oxgc) { # q * *
6896 1         2 my $delimiter = $1;
6897 1 50       4 my $q_string = '';
  14 50       330  
    100          
    50          
6898 0         0 while (not /\G \z/oxgc) {
6899 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6900 1         4 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
6901             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
6902 13         262 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6903             }
6904             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6905 0         0 }
6906             }
6907             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6908             }
6909             }
6910              
6911 0         0 # m//
6912 491 50       1368 elsif (/\G \b (m) \b /oxgc) {
6913 491         7063 my $ope = $1;
6914             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
6915             return e_qr($ope,$1,$3,$2,$4);
6916 0         0 }
6917 491         1112 else {
6918 491 50       1318 my $e = '';
  491 50       23686  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6919 0         0 while (not /\G \z/oxgc) {
6920 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6921 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
6922 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
6923 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
6924 92         258 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
6925 87         260 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
6926 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
6927             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
6928 312         1163 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
6929             }
6930             die __FILE__, ": Search pattern not terminated\n";
6931             }
6932             }
6933              
6934             # s///
6935              
6936             # about [cegimosxpradlunbB]* (/cg modifier)
6937             #
6938             # P.67 Pattern-Matching Operators
6939             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
6940 0         0  
6941             elsif (/\G \b (s) \b /oxgc) {
6942             my $ope = $1;
6943 292 100       929  
6944 292         7301 # $1 $2 $3 $4 $5 $6
6945             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
6946             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
6947 1         5 }
6948 291         677 else {
6949 291 50       958 my $e = '';
  291 50       42799  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6950             while (not /\G \z/oxgc) {
6951 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6952 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6953 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6954             while (not /\G \z/oxgc) {
6955 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6956 0         0 # $1 $2 $3 $4
6957 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6958 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6959 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6960 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6961 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([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             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6965 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6966             }
6967             die __FILE__, ": Substitution replacement not terminated\n";
6968 0         0 }
6969 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6970 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6971             while (not /\G \z/oxgc) {
6972 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6973 0         0 # $1 $2 $3 $4
6974 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6975 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6976 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6977 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6978 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([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 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6981             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6982 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6983             }
6984             die __FILE__, ": Substitution replacement not terminated\n";
6985 0         0 }
6986 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6987 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
6988             while (not /\G \z/oxgc) {
6989 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6990 0         0 # $1 $2 $3 $4
6991 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6992 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6993 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6994 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6995 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6996             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6997 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6998             }
6999             die __FILE__, ": Substitution replacement not terminated\n";
7000 0         0 }
7001 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
7002 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7003             while (not /\G \z/oxgc) {
7004 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7005 0         0 # $1 $2 $3 $4
7006 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7007 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7008 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7009 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7010 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7011 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7012 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7013             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7014 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7015             }
7016             die __FILE__, ": Substitution replacement not terminated\n";
7017             }
7018 0         0 # $1 $2 $3 $4 $5 $6
7019             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
7020             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7021             }
7022 96         392 # $1 $2 $3 $4 $5 $6
7023             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7024             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
7025             }
7026 4         37 # $1 $2 $3 $4 $5 $6
7027             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7028             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7029             }
7030 0         0 # $1 $2 $3 $4 $5 $6
7031             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7032             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7033 191         951 }
7034             }
7035             die __FILE__, ": Substitution pattern not terminated\n";
7036             }
7037             }
7038 0         0  
7039 1         6 # do
7040 0         0 elsif (/\G \b do (?= (?>\s*) \{ ) /oxmsgc) { return 'do'; }
7041 0         0 elsif (/\G \b do (?= (?>\s+) (?: q | qq | qx ) \b) /oxmsgc) { return 'Egb18030::do'; }
7042 0         0 elsif (/\G \b do (?= (?>\s+) (?>\w+)) /oxmsgc) { return 'do'; }
7043             elsif (/\G \b do (?= (?>\s*) \$ (?> \w+ (?: ::\w+)* ) \( ) /oxmsgc) { return 'do'; }
7044             elsif (/\G \b do \b /oxmsgc) { return 'Egb18030::do'; }
7045 2         12  
7046 0         0 # require ignore module
7047 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
7048             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# require$1\n$2"; }
7049             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
7050 0         0  
7051 0         0 # require version number
7052 0         0 elsif (/\G \b require (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7053             elsif (/\G \b require (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7054             elsif (/\G \b require (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7055 0         0  
7056             # require bare package name
7057             elsif (/\G \b require (?>\s+) ((?>[A-Za-z_]\w* (?: :: [A-Za-z_]\w*)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7058 18         126  
7059 0         0 # require else
7060             elsif (/\G \b require (?>\s*) ; /oxmsgc) { return 'Egb18030::require;'; }
7061             elsif (/\G \b require \b /oxmsgc) { return 'Egb18030::require'; }
7062 1         5  
7063 70         611 # use strict; --> use strict; no strict qw(refs);
7064 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
7065             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
7066             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
7067              
7068 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
7069 3         92 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7070             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
7071             return "use $1; no strict qw(refs);";
7072 0         0 }
7073             else {
7074             return "use $1;";
7075             }
7076 3 0 0     18 }
      0        
7077 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7078             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
7079             return "use $1; no strict qw(refs);";
7080 0         0 }
7081             else {
7082             return "use $1;";
7083             }
7084             }
7085 0         0  
7086 2         17 # ignore use module
7087 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
7088             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# use$1\n$2"; }
7089             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
7090 0         0  
7091 0         0 # ignore no module
7092 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
7093             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# no$1\n$2"; }
7094             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
7095 0         0  
7096 0         0 # use without import
7097 0         0 elsif (/\G \b use (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7098 0         0 elsif (/\G \b use (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7099 0         0 elsif (/\G \b use (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7100 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7101 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7102 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7103 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7104 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7105             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7106             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7107 0         0  
7108             # use with import no parameter
7109             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_use_noparam($1); }
7110 0         0  
7111 0         0 # use with import parameters
7112 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7113 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\xFE']* \') (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7114 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\xFE"]* \") (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7115 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); }
7116 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); }
7117 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); }
7118 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); }
7119             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7120             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); }
7121 0         0  
7122 0         0 # no without unimport
7123 0         0 elsif (/\G \b no (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7124 0         0 elsif (/\G \b no (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7125 0         0 elsif (/\G \b no (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7126 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7127 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7128 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7129 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7130 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7131             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7132             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7133 0         0  
7134             # no with unimport no parameter
7135             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_no_noparam($1); }
7136 0         0  
7137 0         0 # no with unimport parameters
7138 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7139 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\xFE']* \') (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7140 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\xFE"]* \") (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7141 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); }
7142 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); }
7143 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); }
7144 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); }
7145             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7146             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); }
7147 0         0  
7148             # use else
7149             elsif (/\G \b use \b /oxmsgc) { return "use"; }
7150 0         0  
7151             # use else
7152             elsif (/\G \b no \b /oxmsgc) { return "no"; }
7153              
7154 2         9 # ''
7155 3249         10921 elsif (/\G (?
7156 3249 100       11505 my $q_string = '';
  16060 100       61972  
    100          
    50          
7157 8         22 while (not /\G \z/oxgc) {
7158 48         84 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
7159 3249         8383 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
7160             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
7161 12755         29738 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7162             }
7163             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7164             }
7165              
7166 0         0 # ""
7167 3465         8918 elsif (/\G (\") /oxgc) {
7168 3465 100       10758 my $qq_string = '';
  72501 100       230079  
    100          
    50          
7169 109         228 while (not /\G \z/oxgc) {
7170 14         27 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7171 3465         9528 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
7172             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
7173 68913         163457 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
7174             }
7175             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7176             }
7177              
7178 0         0 # ``
7179 38         136 elsif (/\G (\`) /oxgc) {
7180 38 50       182 my $qx_string = '';
  318 50       3288  
    100          
    50          
7181 0         0 while (not /\G \z/oxgc) {
7182 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
7183 38         159 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
7184             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
7185 280         951 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
7186             }
7187             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7188             }
7189              
7190 0         0 # // --- not divide operator (num / num), not defined-or
7191 1239         3305 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
7192 1239 100       4383 my $regexp = '';
  12674 50       47206  
    100          
    50          
7193 11         35 while (not /\G \z/oxgc) {
7194 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7195 1239         3831 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
7196             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
7197 11424         25129 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7198             }
7199             die __FILE__, ": Search pattern not terminated\n";
7200             }
7201              
7202 0         0 # ?? --- not conditional operator (condition ? then : else)
7203 92         258 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
7204 92 50       267 my $regexp = '';
  266 50       1141  
    100          
    50          
7205 0         0 while (not /\G \z/oxgc) {
7206 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7207 92         255 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
7208             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
7209 174         429 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7210             }
7211             die __FILE__, ": Search pattern not terminated\n";
7212             }
7213 0         0  
  0         0  
7214             # <<>> (a safer ARGV)
7215             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
7216 0         0  
  0         0  
7217             # << (bit shift) --- not here document
7218             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
7219              
7220 0         0 # <<~'HEREDOC'
7221 6         18 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
7222 6         14 $slash = 'm//';
7223             my $here_quote = $1;
7224             my $delimiter = $2;
7225 6 50       11  
7226 6         12 # get here document
7227 6         38 if ($here_script eq '') {
7228             $here_script = CORE::substr $_, pos $_;
7229 6 50       34 $here_script =~ s/.*?\n//oxm;
7230 6         58 }
7231 6         16 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7232 6         11 my $heredoc = $1;
7233 6         63 my $indent = $2;
7234 6         20 $heredoc =~ s{^$indent}{}msg; # no /ox
7235             push @heredoc, $heredoc . qq{\n$delimiter\n};
7236             push @heredoc_delimiter, qq{\\s*$delimiter};
7237 6         14 }
7238             else {
7239 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7240             }
7241             return qq{<<'$delimiter'};
7242             }
7243              
7244             # <<~\HEREDOC
7245              
7246             # P.66 2.6.6. "Here" Documents
7247             # in Chapter 2: Bits and Pieces
7248             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7249              
7250             # P.73 "Here" Documents
7251             # in Chapter 2: Bits and Pieces
7252             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7253 6         28  
7254 3         60 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
7255 3         9 $slash = 'm//';
7256             my $here_quote = $1;
7257             my $delimiter = $2;
7258 3 50       9  
7259 3         10 # get here document
7260 3         15 if ($here_script eq '') {
7261             $here_script = CORE::substr $_, pos $_;
7262 3 50       19 $here_script =~ s/.*?\n//oxm;
7263 3         43 }
7264 3         8 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7265 3         249 my $heredoc = $1;
7266 3         45 my $indent = $2;
7267 3         16 $heredoc =~ s{^$indent}{}msg; # no /ox
7268             push @heredoc, $heredoc . qq{\n$delimiter\n};
7269             push @heredoc_delimiter, qq{\\s*$delimiter};
7270 3         8 }
7271             else {
7272 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7273             }
7274             return qq{<<\\$delimiter};
7275             }
7276              
7277 3         14 # <<~"HEREDOC"
7278 6         37 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
7279 6         15 $slash = 'm//';
7280             my $here_quote = $1;
7281             my $delimiter = $2;
7282 6 50       12  
7283 6         15 # get here document
7284 6         26 if ($here_script eq '') {
7285             $here_script = CORE::substr $_, pos $_;
7286 6 50       34 $here_script =~ s/.*?\n//oxm;
7287 6         65 }
7288 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7289 6         11 my $heredoc = $1;
7290 6         51 my $indent = $2;
7291 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
7292             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7293             push @heredoc_delimiter, qq{\\s*$delimiter};
7294 6         17 }
7295             else {
7296 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7297             }
7298             return qq{<<"$delimiter"};
7299             }
7300              
7301 6         27 # <<~HEREDOC
7302 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
7303 3         8 $slash = 'm//';
7304             my $here_quote = $1;
7305             my $delimiter = $2;
7306 3 50       7  
7307 3         10 # get here document
7308 3         14 if ($here_script eq '') {
7309             $here_script = CORE::substr $_, pos $_;
7310 3 50       35 $here_script =~ s/.*?\n//oxm;
7311 3         40 }
7312 3         8 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7313 3         6 my $heredoc = $1;
7314 3         38 my $indent = $2;
7315 3         12 $heredoc =~ s{^$indent}{}msg; # no /ox
7316             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7317             push @heredoc_delimiter, qq{\\s*$delimiter};
7318 3         8 }
7319             else {
7320 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7321             }
7322             return qq{<<$delimiter};
7323             }
7324              
7325 3         13 # <<~`HEREDOC`
7326 6         15 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
7327 6         15 $slash = 'm//';
7328             my $here_quote = $1;
7329             my $delimiter = $2;
7330 6 50       10  
7331 6         33 # get here document
7332 6         27 if ($here_script eq '') {
7333             $here_script = CORE::substr $_, pos $_;
7334 6 50       37 $here_script =~ s/.*?\n//oxm;
7335 6         305 }
7336 6         18 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7337 6         153 my $heredoc = $1;
7338 6         71 my $indent = $2;
7339 6         22 $heredoc =~ s{^$indent}{}msg; # no /ox
7340             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7341             push @heredoc_delimiter, qq{\\s*$delimiter};
7342 6         18 }
7343             else {
7344 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7345             }
7346             return qq{<<`$delimiter`};
7347             }
7348              
7349 6         27 # <<'HEREDOC'
7350 86         207 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
7351 86         201 $slash = 'm//';
7352             my $here_quote = $1;
7353             my $delimiter = $2;
7354 86 100       146  
7355 86         209 # get here document
7356 83         877 if ($here_script eq '') {
7357             $here_script = CORE::substr $_, pos $_;
7358 83 50       456 $here_script =~ s/.*?\n//oxm;
7359 86         735 }
7360 86         371 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7361             push @heredoc, $1 . qq{\n$delimiter\n};
7362             push @heredoc_delimiter, $delimiter;
7363 86         147 }
7364             else {
7365 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7366             }
7367             return $here_quote;
7368             }
7369              
7370             # <<\HEREDOC
7371              
7372             # P.66 2.6.6. "Here" Documents
7373             # in Chapter 2: Bits and Pieces
7374             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7375              
7376             # P.73 "Here" Documents
7377             # in Chapter 2: Bits and Pieces
7378             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7379 86         646  
7380 2         5 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
7381 2         5 $slash = 'm//';
7382             my $here_quote = $1;
7383             my $delimiter = $2;
7384 2 100       5  
7385 2         5 # get here document
7386 1         6 if ($here_script eq '') {
7387             $here_script = CORE::substr $_, pos $_;
7388 1 50       5 $here_script =~ s/.*?\n//oxm;
7389 2         25 }
7390 2         8 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7391             push @heredoc, $1 . qq{\n$delimiter\n};
7392             push @heredoc_delimiter, $delimiter;
7393 2         13 }
7394             else {
7395 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7396             }
7397             return $here_quote;
7398             }
7399              
7400 2         10 # <<"HEREDOC"
7401 39         110 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
7402 39         102 $slash = 'm//';
7403             my $here_quote = $1;
7404             my $delimiter = $2;
7405 39 100       78  
7406 39         151 # get here document
7407 38         256 if ($here_script eq '') {
7408             $here_script = CORE::substr $_, pos $_;
7409 38 50       229 $here_script =~ s/.*?\n//oxm;
7410 39         505 }
7411 39         138 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7412             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7413             push @heredoc_delimiter, $delimiter;
7414 39         96 }
7415             else {
7416 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7417             }
7418             return $here_quote;
7419             }
7420              
7421 39         162 # <
7422 60         158 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
7423 60         143 $slash = 'm//';
7424             my $here_quote = $1;
7425             my $delimiter = $2;
7426 60 100       113  
7427 60         174 # get here document
7428 57         361 if ($here_script eq '') {
7429             $here_script = CORE::substr $_, pos $_;
7430 57 50       332 $here_script =~ s/.*?\n//oxm;
7431 60         752 }
7432 60         209 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7433             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7434             push @heredoc_delimiter, $delimiter;
7435 60         134 }
7436             else {
7437 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7438             }
7439             return $here_quote;
7440             }
7441              
7442 60         248 # <<`HEREDOC`
7443 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
7444 0         0 $slash = 'm//';
7445             my $here_quote = $1;
7446             my $delimiter = $2;
7447 0 0       0  
7448 0         0 # get here document
7449 0         0 if ($here_script eq '') {
7450             $here_script = CORE::substr $_, pos $_;
7451 0 0       0 $here_script =~ s/.*?\n//oxm;
7452 0         0 }
7453 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7454             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7455             push @heredoc_delimiter, $delimiter;
7456 0         0 }
7457             else {
7458 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7459             }
7460             return $here_quote;
7461             }
7462              
7463 0         0 # <<= <=> <= < operator
7464             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
7465             return $1;
7466             }
7467              
7468 13         83 #
7469             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
7470             return $1;
7471             }
7472              
7473             # --- glob
7474              
7475             # avoid "Error: Runtime exception" of perl version 5.005_03
7476 0         0  
7477             elsif (/\G < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF])+?) > /oxgc) {
7478             return 'Egb18030::glob("' . $1 . '")';
7479             }
7480 0         0  
7481             # __DATA__
7482             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
7483 0         0  
7484             # __END__
7485             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
7486              
7487             # \cD Control-D
7488              
7489             # P.68 2.6.8. Other Literal Tokens
7490             # in Chapter 2: Bits and Pieces
7491             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7492              
7493             # P.76 Other Literal Tokens
7494             # in Chapter 2: Bits and Pieces
7495 384         3232 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7496              
7497             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
7498 0         0  
7499             # \cZ Control-Z
7500             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
7501              
7502             # any operator before div
7503             elsif (/\G (
7504             -- | \+\+ |
7505 0         0 [\)\}\]]
  14318         37624  
7506              
7507             ) /oxgc) { $slash = 'div'; return $1; }
7508              
7509             # yada-yada or triple-dot operator
7510             elsif (/\G (
7511 14318         89639 \.\.\.
  7         15  
7512              
7513             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
7514              
7515             # any operator before m//
7516              
7517             # //, //= (defined-or)
7518              
7519             # P.164 Logical Operators
7520             # in Chapter 10: More Control Structures
7521             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7522              
7523             # P.119 C-Style Logical (Short-Circuit) Operators
7524             # in Chapter 3: Unary and Binary Operators
7525             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7526              
7527             # (and so on)
7528              
7529             # ~~
7530              
7531             # P.221 The Smart Match Operator
7532             # in Chapter 15: Smart Matching and given-when
7533             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7534              
7535             # P.112 Smartmatch Operator
7536             # in Chapter 3: Unary and Binary Operators
7537             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7538              
7539             # (and so on)
7540              
7541             elsif (/\G ((?>
7542              
7543             !~~ | !~ | != | ! |
7544             %= | % |
7545             &&= | && | &= | &\.= | &\. | & |
7546             -= | -> | - |
7547             :(?>\s*)= |
7548             : |
7549             <<>> |
7550             <<= | <=> | <= | < |
7551             == | => | =~ | = |
7552             >>= | >> | >= | > |
7553             \*\*= | \*\* | \*= | \* |
7554             \+= | \+ |
7555             \.\. | \.= | \. |
7556             \/\/= | \/\/ |
7557             \/= | \/ |
7558             \? |
7559             \\ |
7560             \^= | \^\.= | \^\. | \^ |
7561             \b x= |
7562             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
7563             ~~ | ~\. | ~ |
7564             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
7565             \b(?: print )\b |
7566              
7567 7         27 [,;\(\{\[]
  24138         55308  
7568              
7569             )) /oxgc) { $slash = 'm//'; return $1; }
7570 24138         124995  
  38055         103075  
7571             # other any character
7572             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
7573              
7574 38055         258146 # system error
7575             else {
7576             die __FILE__, ": Oops, this shouldn't happen!\n";
7577             }
7578             }
7579              
7580 0     3279 0 0 # escape GB18030 string
7581 3279         9614 sub e_string {
7582             my($string) = @_;
7583 3279         5127 my $e_string = '';
7584              
7585             local $slash = 'm//';
7586              
7587             # P.1024 Appendix W.10 Multibyte Processing
7588             # of ISBN 1-56592-224-7 CJKV Information Processing
7589 3279         5199 # (and so on)
7590              
7591             my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\$q_char|$q_char) /oxmsg;
7592 3279 100 66     50213  
7593 3279 50       15197 # without { ... }
7594 3200         9104 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
7595             if ($string !~ /<
7596             return $string;
7597             }
7598             }
7599 3200         9131  
7600 79 50       275 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          
7601             while ($string !~ /\G \z/oxgc) {
7602             if (0) {
7603             }
7604 606         109121  
7605 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Egb18030::PREMATCH()]}
7606 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
7607             $e_string .= q{Egb18030::PREMATCH()};
7608             $slash = 'div';
7609             }
7610              
7611 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Egb18030::MATCH()]}
7612 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
7613             $e_string .= q{Egb18030::MATCH()};
7614             $slash = 'div';
7615             }
7616              
7617 0         0 # $', ${'} --> $', ${'}
7618 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
7619             $e_string .= $1;
7620             $slash = 'div';
7621             }
7622              
7623 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Egb18030::POSTMATCH()]}
7624 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
7625             $e_string .= q{Egb18030::POSTMATCH()};
7626             $slash = 'div';
7627             }
7628              
7629 0         0 # bareword
7630 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
7631             $e_string .= $1;
7632             $slash = 'div';
7633             }
7634              
7635 0         0 # $0 --> $0
7636 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
7637             $e_string .= $1;
7638             $slash = 'div';
7639 0         0 }
7640 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
7641             $e_string .= $1;
7642             $slash = 'div';
7643             }
7644              
7645 0         0 # $$ --> $$
7646 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
7647             $e_string .= $1;
7648             $slash = 'div';
7649             }
7650              
7651             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7652 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7653 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
7654             $e_string .= e_capture($1);
7655             $slash = 'div';
7656 0         0 }
7657 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
7658             $e_string .= e_capture($1);
7659             $slash = 'div';
7660             }
7661              
7662 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7663 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
7664             $e_string .= e_capture($1.'->'.$2);
7665             $slash = 'div';
7666             }
7667              
7668 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7669 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
7670             $e_string .= e_capture($1.'->'.$2);
7671             $slash = 'div';
7672             }
7673              
7674 0         0 # $$foo
7675 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
7676             $e_string .= e_capture($1);
7677             $slash = 'div';
7678             }
7679              
7680 0         0 # ${ foo }
7681 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
7682             $e_string .= '${' . $1 . '}';
7683             $slash = 'div';
7684             }
7685              
7686 0         0 # ${ ... }
7687 3         10 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
7688             $e_string .= e_capture($1);
7689             $slash = 'div';
7690             }
7691              
7692             # variable or function
7693 3         16 # $ @ % & * $ #
7694 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) {
7695             $e_string .= $1;
7696             $slash = 'div';
7697             }
7698             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
7699 0         0 # $ @ # \ ' " / ? ( ) [ ] < >
7700 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
7701             $e_string .= $1;
7702             $slash = 'div';
7703             }
7704 0         0  
  0         0  
7705 0         0 # subroutines of package Egb18030
  0         0  
7706 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
7707 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7708 0         0 elsif ($string =~ /\G \b GB18030::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7709 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
7710 0         0 elsif ($string =~ /\G \b GB18030::eval \b /oxgc) { $e_string .= 'eval GB18030::escape'; $slash = 'm//'; }
  0         0  
7711 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
7712 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Egb18030::chop'; $slash = 'm//'; }
  0         0  
7713 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
7714 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
7715 0         0 elsif ($string =~ /\G \b GB18030::index \b /oxgc) { $e_string .= 'GB18030::index'; $slash = 'm//'; }
  0         0  
7716 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Egb18030::index'; $slash = 'm//'; }
  0         0  
7717 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
7718 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
7719 0         0 elsif ($string =~ /\G \b GB18030::rindex \b /oxgc) { $e_string .= 'GB18030::rindex'; $slash = 'm//'; }
  0         0  
7720 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Egb18030::rindex'; $slash = 'm//'; }
  0         0  
7721 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egb18030::lc'; $slash = 'm//'; }
  0         0  
7722 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egb18030::lcfirst'; $slash = 'm//'; }
  0         0  
7723 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egb18030::uc'; $slash = 'm//'; }
  0         0  
7724             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egb18030::ucfirst'; $slash = 'm//'; }
7725 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egb18030::fc'; $slash = 'm//'; }
  0         0  
7726 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7727 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7728 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7729 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7730 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7731 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         8  
7732             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7733             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7734 1         5  
  1         7  
7735 1         5 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7736 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7737 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7738 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7739 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7740 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  1         7  
7741             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7742             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Egb18030::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7743 1         3  
  0         0  
7744 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7745 0         0 { $e_string .= "Egb18030::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7746 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Egb18030::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7747             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $e_string .= "Egb18030::filetest qw($1),"; $slash = 'm//'; }
7748 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $e_string .= "Egb18030::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7749 0         0  
  0         0  
7750 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Egb18030::$1(" . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7751 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7752 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7753 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7754 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  2         10  
7755             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7756 2         7 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Egb18030::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         6  
7757 1         4  
  0         0  
7758 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Egb18030::$1(" . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7759 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7760 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7761 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7762 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  2         22  
7763             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7764             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Egb18030::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7765 2         8  
  0         0  
7766 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7767 0         0 { $e_string .= "Egb18030::$1($2)"; $slash = 'm//'; }
  0         0  
7768 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Egb18030::$1($2)"; $slash = 'm//'; }
  0         0  
7769 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= "Egb18030::$1"; $slash = 'm//'; }
  0         0  
7770 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "Egb18030::$1(::"."$2)"; $slash = 'm//'; }
  0         0  
7771 0         0 elsif ($string =~ /\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-t $2"; $slash = 'm//'; }
  0         0  
7772             elsif ($string =~ /\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egb18030::lstat'; $slash = 'm//'; }
7773             elsif ($string =~ /\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egb18030::stat'; $slash = 'm//'; }
7774 0         0  
  0         0  
7775 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
7776 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7777 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  
7778 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  
7779 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  
7780 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  
7781             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
7782 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  
7783 0         0  
  0         0  
7784 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7785 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  
7786 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  
7787 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  
7788 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  
7789             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7790             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7791 0         0  
  0         0  
7792 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
7793 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7794 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
7795             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
7796 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7797 0         0  
  0         0  
7798 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7799 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7800 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egb18030::chr'; $slash = 'm//'; }
  0         0  
7801 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7802 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
7803 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Egb18030::glob'; $slash = 'm//'; }
  0         0  
7804 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Egb18030::lc_'; $slash = 'm//'; }
  0         0  
7805 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Egb18030::lcfirst_'; $slash = 'm//'; }
  0         0  
7806 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Egb18030::uc_'; $slash = 'm//'; }
  0         0  
7807 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Egb18030::ucfirst_'; $slash = 'm//'; }
  0         0  
7808 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Egb18030::fc_'; $slash = 'm//'; }
  0         0  
7809             elsif ($string =~ /\G \b lstat \b /oxgc) { $e_string .= 'Egb18030::lstat_'; $slash = 'm//'; }
7810 0         0 elsif ($string =~ /\G \b stat \b /oxgc) { $e_string .= 'Egb18030::stat_'; $slash = 'm//'; }
  0         0  
7811 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7812 0         0 \b /oxgc) { $e_string .= "Egb18030::filetest_(qw($1))"; $slash = 'm//'; }
  0         0  
7813             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) \b /oxgc) { $e_string .= "Egb18030::${1}_"; $slash = 'm//'; }
7814 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
7815 0         0  
  0         0  
7816 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7817 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7818 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Egb18030::chr_'; $slash = 'm//'; }
  0         0  
7819 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7820 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
7821 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Egb18030::glob_'; $slash = 'm//'; }
  0         0  
7822 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
7823 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
7824 0         0 elsif ($string =~ /\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Egb18030::opendir$1*"; $slash = 'm//'; }
  0         0  
7825             elsif ($string =~ /\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Egb18030::opendir$1*"; $slash = 'm//'; }
7826             elsif ($string =~ /\G \b unlink \b /oxgc) { $e_string .= 'Egb18030::unlink'; $slash = 'm//'; }
7827              
7828 0         0 # chdir
7829             elsif ($string =~ /\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
7830 0         0 $slash = 'm//';
7831              
7832 0         0 $e_string .= 'Egb18030::chdir';
7833 0         0  
7834             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7835             $e_string .= $1;
7836             }
7837 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
7838             # end of chdir
7839             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return $e_string; }
7840 0         0  
  0         0  
7841             # chdir scalar value
7842             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= e_string($1); next E_STRING_LOOP; }
7843              
7844 0 0       0 # chdir qq//
  0         0  
  0         0  
7845             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7846 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq# # --> qr # #
7847 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7848 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7849 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7850 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
7851 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
7852 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
7853 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
7854             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq','{','}',$2); next E_STRING_LOOP; } # qq | | --> qr { }
7855 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq * * --> qr * *
7856             }
7857             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7858             }
7859             }
7860              
7861 0 0       0 # chdir q//
  0         0  
  0         0  
7862             elsif ($string =~ /\G \b (q) \b /oxgc) {
7863 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q# # --> qr # #
7864 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7865 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7866 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7867 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  
7868 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  
7869 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  
7870 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  
7871             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q','{','}',$2); next E_STRING_LOOP; } # q | | --> qr { }
7872 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 * *
7873             }
7874             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7875             }
7876             }
7877              
7878 0         0 # chdir ''
7879 0         0 elsif ($string =~ /\G (\') /oxgc) {
7880 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7881 0         0 while ($string !~ /\G \z/oxgc) {
7882 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7883 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; }
7884             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_chdir_q('',"'","'",$q_string); next E_STRING_LOOP; }
7885 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7886             }
7887             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7888             }
7889              
7890 0         0 # chdir ""
7891 0         0 elsif ($string =~ /\G (\") /oxgc) {
7892 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
7893 0         0 while ($string !~ /\G \z/oxgc) {
7894 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
7895 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; }
7896             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_chdir('','"','"',$qq_string); next E_STRING_LOOP; }
7897 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
7898             }
7899             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7900             }
7901             }
7902              
7903 0         0 # split
7904             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
7905 0         0 $slash = 'm//';
7906 0         0  
7907 0         0 my $e = '';
7908             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7909             $e .= $1;
7910             }
7911 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          
7912             # end of split
7913             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Egb18030::split' . $e; }
7914 0         0  
  0         0  
7915             # split scalar value
7916             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Egb18030::split' . $e . e_string($1); next E_STRING_LOOP; }
7917 0         0  
  0         0  
7918 0         0 # split literal space
  0         0  
7919 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
7920 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7921 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7922 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7923 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7924 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7925 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
7926 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7927 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7928 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7929 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7930 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Egb18030::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7931             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Egb18030::split' . $e . qq {' '}; next E_STRING_LOOP; }
7932             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Egb18030::split' . $e . qq {" "}; next E_STRING_LOOP; }
7933              
7934 0 0       0 # split qq//
  0         0  
  0         0  
7935             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7936 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
7937 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7938 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7939 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7940 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  
7941 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  
7942 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  
7943 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  
7944             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
7945 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 * *
7946             }
7947             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7948             }
7949             }
7950              
7951 0 0       0 # split qr//
  0         0  
  0         0  
7952             elsif ($string =~ /\G \b (qr) \b /oxgc) {
7953 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
7954 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7955 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7956 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7957 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  
7958 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  
7959 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  
7960 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  
7961 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  
7962             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
7963 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 * *
7964             }
7965             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7966             }
7967             }
7968              
7969 0 0       0 # split q//
  0         0  
  0         0  
7970             elsif ($string =~ /\G \b (q) \b /oxgc) {
7971 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
7972 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7973 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7974 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7975 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  
7976 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  
7977 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  
7978 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  
7979             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
7980 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 * *
7981             }
7982             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7983             }
7984             }
7985              
7986 0 0       0 # split m//
  0         0  
  0         0  
7987             elsif ($string =~ /\G \b (m) \b /oxgc) {
7988 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 # #
7989 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7990 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7991 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7992 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  
7993 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  
7994 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  
7995 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  
7996 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  
7997             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
7998 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 * *
7999             }
8000             die __FILE__, ": Search pattern not terminated\n";
8001             }
8002             }
8003              
8004 0         0 # split ''
8005 0         0 elsif ($string =~ /\G (\') /oxgc) {
8006 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
8007 0         0 while ($string !~ /\G \z/oxgc) {
8008 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
8009 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
8010             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
8011 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
8012             }
8013             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8014             }
8015              
8016 0         0 # split ""
8017 0         0 elsif ($string =~ /\G (\") /oxgc) {
8018 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
8019 0         0 while ($string !~ /\G \z/oxgc) {
8020 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
8021 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
8022             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
8023 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
8024             }
8025             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8026             }
8027              
8028 0         0 # split //
8029 0         0 elsif ($string =~ /\G (\/) /oxgc) {
8030 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
8031 0         0 while ($string !~ /\G \z/oxgc) {
8032 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
8033 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
8034             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
8035 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
8036             }
8037             die __FILE__, ": Search pattern not terminated\n";
8038             }
8039             }
8040              
8041 0         0 # qq//
8042 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
8043 0         0 my $ope = $1;
8044             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
8045             $e_string .= e_qq($ope,$1,$3,$2);
8046 0         0 }
8047 0         0 else {
8048 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8049 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8050 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8051 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
8052 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
8053 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
8054             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
8055 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
8056             }
8057             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8058             }
8059             }
8060              
8061 0         0 # qx//
8062 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
8063 0         0 my $ope = $1;
8064             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
8065             $e_string .= e_qq($ope,$1,$3,$2);
8066 0         0 }
8067 0         0 else {
8068 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8069 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8070 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8071 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
8072 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
8073 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
8074 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
8075             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
8076 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
8077             }
8078             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8079             }
8080             }
8081              
8082 0         0 # q//
8083 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
8084 0         0 my $ope = $1;
8085             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
8086             $e_string .= e_q($ope,$1,$3,$2);
8087 0         0 }
8088 0         0 else {
8089 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8090 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8091 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8092 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
8093 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
8094 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
8095             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
8096 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 * *
8097             }
8098             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8099             }
8100             }
8101 0         0  
8102             # ''
8103             elsif ($string =~ /\G (?
8104 44         198  
8105             # ""
8106             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8107 6         111  
8108             # ``
8109             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8110 0         0  
8111             # <<>> (a safer ARGV)
8112             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
8113 0         0  
8114             # <<= <=> <= < operator
8115             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
8116 0         0  
8117             #
8118             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
8119              
8120 0         0 # --- glob
8121             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
8122             $e_string .= 'Egb18030::glob("' . $1 . '")';
8123             }
8124              
8125 0         0 # << (bit shift) --- not here document
8126 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
8127             $slash = 'm//';
8128             $e_string .= $1;
8129             }
8130              
8131 0         0 # <<~'HEREDOC'
8132 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
8133 0         0 $slash = 'm//';
8134             my $here_quote = $1;
8135             my $delimiter = $2;
8136 0 0       0  
8137 0         0 # get here document
8138 0         0 if ($here_script eq '') {
8139             $here_script = CORE::substr $_, pos $_;
8140 0 0       0 $here_script =~ s/.*?\n//oxm;
8141 0         0 }
8142 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8143 0         0 my $heredoc = $1;
8144 0         0 my $indent = $2;
8145 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8146             push @heredoc, $heredoc . qq{\n$delimiter\n};
8147             push @heredoc_delimiter, qq{\\s*$delimiter};
8148 0         0 }
8149             else {
8150 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8151             }
8152             $e_string .= qq{<<'$delimiter'};
8153             }
8154              
8155 0         0 # <<~\HEREDOC
8156 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
8157 0         0 $slash = 'm//';
8158             my $here_quote = $1;
8159             my $delimiter = $2;
8160 0 0       0  
8161 0         0 # get here document
8162 0         0 if ($here_script eq '') {
8163             $here_script = CORE::substr $_, pos $_;
8164 0 0       0 $here_script =~ s/.*?\n//oxm;
8165 0         0 }
8166 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8167 0         0 my $heredoc = $1;
8168 0         0 my $indent = $2;
8169 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8170             push @heredoc, $heredoc . qq{\n$delimiter\n};
8171             push @heredoc_delimiter, qq{\\s*$delimiter};
8172 0         0 }
8173             else {
8174 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8175             }
8176             $e_string .= qq{<<\\$delimiter};
8177             }
8178              
8179 0         0 # <<~"HEREDOC"
8180 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
8181 0         0 $slash = 'm//';
8182             my $here_quote = $1;
8183             my $delimiter = $2;
8184 0 0       0  
8185 0         0 # get here document
8186 0         0 if ($here_script eq '') {
8187             $here_script = CORE::substr $_, pos $_;
8188 0 0       0 $here_script =~ s/.*?\n//oxm;
8189 0         0 }
8190 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8191 0         0 my $heredoc = $1;
8192 0         0 my $indent = $2;
8193 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8194             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8195             push @heredoc_delimiter, qq{\\s*$delimiter};
8196 0         0 }
8197             else {
8198 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8199             }
8200             $e_string .= qq{<<"$delimiter"};
8201             }
8202              
8203 0         0 # <<~HEREDOC
8204 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
8205 0         0 $slash = 'm//';
8206             my $here_quote = $1;
8207             my $delimiter = $2;
8208 0 0       0  
8209 0         0 # get here document
8210 0         0 if ($here_script eq '') {
8211             $here_script = CORE::substr $_, pos $_;
8212 0 0       0 $here_script =~ s/.*?\n//oxm;
8213 0         0 }
8214 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8215 0         0 my $heredoc = $1;
8216 0         0 my $indent = $2;
8217 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8218             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8219             push @heredoc_delimiter, qq{\\s*$delimiter};
8220 0         0 }
8221             else {
8222 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8223             }
8224             $e_string .= qq{<<$delimiter};
8225             }
8226              
8227 0         0 # <<~`HEREDOC`
8228 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
8229 0         0 $slash = 'm//';
8230             my $here_quote = $1;
8231             my $delimiter = $2;
8232 0 0       0  
8233 0         0 # get here document
8234 0         0 if ($here_script eq '') {
8235             $here_script = CORE::substr $_, pos $_;
8236 0 0       0 $here_script =~ s/.*?\n//oxm;
8237 0         0 }
8238 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8239 0         0 my $heredoc = $1;
8240 0         0 my $indent = $2;
8241 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8242             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8243             push @heredoc_delimiter, qq{\\s*$delimiter};
8244 0         0 }
8245             else {
8246 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8247             }
8248             $e_string .= qq{<<`$delimiter`};
8249             }
8250              
8251 0         0 # <<'HEREDOC'
8252 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
8253 0         0 $slash = 'm//';
8254             my $here_quote = $1;
8255             my $delimiter = $2;
8256 0 0       0  
8257 0         0 # get here document
8258 0         0 if ($here_script eq '') {
8259             $here_script = CORE::substr $_, pos $_;
8260 0 0       0 $here_script =~ s/.*?\n//oxm;
8261 0         0 }
8262 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8263             push @heredoc, $1 . qq{\n$delimiter\n};
8264             push @heredoc_delimiter, $delimiter;
8265 0         0 }
8266             else {
8267 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8268             }
8269             $e_string .= $here_quote;
8270             }
8271              
8272 0         0 # <<\HEREDOC
8273 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
8274 0         0 $slash = 'm//';
8275             my $here_quote = $1;
8276             my $delimiter = $2;
8277 0 0       0  
8278 0         0 # get here document
8279 0         0 if ($here_script eq '') {
8280             $here_script = CORE::substr $_, pos $_;
8281 0 0       0 $here_script =~ s/.*?\n//oxm;
8282 0         0 }
8283 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8284             push @heredoc, $1 . qq{\n$delimiter\n};
8285             push @heredoc_delimiter, $delimiter;
8286 0         0 }
8287             else {
8288 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8289             }
8290             $e_string .= $here_quote;
8291             }
8292              
8293 0         0 # <<"HEREDOC"
8294 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
8295 0         0 $slash = 'm//';
8296             my $here_quote = $1;
8297             my $delimiter = $2;
8298 0 0       0  
8299 0         0 # get here document
8300 0         0 if ($here_script eq '') {
8301             $here_script = CORE::substr $_, pos $_;
8302 0 0       0 $here_script =~ s/.*?\n//oxm;
8303 0         0 }
8304 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8305             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8306             push @heredoc_delimiter, $delimiter;
8307 0         0 }
8308             else {
8309 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8310             }
8311             $e_string .= $here_quote;
8312             }
8313              
8314 0         0 # <
8315 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
8316 0         0 $slash = 'm//';
8317             my $here_quote = $1;
8318             my $delimiter = $2;
8319 0 0       0  
8320 0         0 # get here document
8321 0         0 if ($here_script eq '') {
8322             $here_script = CORE::substr $_, pos $_;
8323 0 0       0 $here_script =~ s/.*?\n//oxm;
8324 0         0 }
8325 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8326             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8327             push @heredoc_delimiter, $delimiter;
8328 0         0 }
8329             else {
8330 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8331             }
8332             $e_string .= $here_quote;
8333             }
8334              
8335 0         0 # <<`HEREDOC`
8336 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
8337 0         0 $slash = 'm//';
8338             my $here_quote = $1;
8339             my $delimiter = $2;
8340 0 0       0  
8341 0         0 # get here document
8342 0         0 if ($here_script eq '') {
8343             $here_script = CORE::substr $_, pos $_;
8344 0 0       0 $here_script =~ s/.*?\n//oxm;
8345 0         0 }
8346 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8347             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8348             push @heredoc_delimiter, $delimiter;
8349 0         0 }
8350             else {
8351 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8352             }
8353             $e_string .= $here_quote;
8354             }
8355              
8356             # any operator before div
8357             elsif ($string =~ /\G (
8358             -- | \+\+ |
8359 0         0 [\)\}\]]
  80         173  
8360              
8361             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
8362              
8363             # yada-yada or triple-dot operator
8364             elsif ($string =~ /\G (
8365 80         284 \.\.\.
  0         0  
8366              
8367             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
8368              
8369             # any operator before m//
8370             elsif ($string =~ /\G ((?>
8371              
8372             !~~ | !~ | != | ! |
8373             %= | % |
8374             &&= | && | &= | &\.= | &\. | & |
8375             -= | -> | - |
8376             :(?>\s*)= |
8377             : |
8378             <<>> |
8379             <<= | <=> | <= | < |
8380             == | => | =~ | = |
8381             >>= | >> | >= | > |
8382             \*\*= | \*\* | \*= | \* |
8383             \+= | \+ |
8384             \.\. | \.= | \. |
8385             \/\/= | \/\/ |
8386             \/= | \/ |
8387             \? |
8388             \\ |
8389             \^= | \^\.= | \^\. | \^ |
8390             \b x= |
8391             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
8392             ~~ | ~\. | ~ |
8393             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
8394             \b(?: print )\b |
8395              
8396 0         0 [,;\(\{\[]
  112         253  
8397              
8398             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
8399 112         1149  
8400             # other any character
8401             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
8402              
8403 353         2822 # system error
8404             else {
8405             die __FILE__, ": Oops, this shouldn't happen!\n";
8406             }
8407 0         0 }
8408              
8409             return $e_string;
8410             }
8411              
8412             #
8413             # character class
8414 79     5494 0 356 #
8415             sub character_class {
8416 5494 100       11378 my($char,$modifier) = @_;
8417 5494 100       9296  
8418 115         320 if ($char eq '.') {
8419             if ($modifier =~ /s/) {
8420             return '${Egb18030::dot_s}';
8421 23         107 }
8422             else {
8423             return '${Egb18030::dot}';
8424             }
8425 92         206 }
8426             else {
8427             return Egb18030::classic_character_class($char);
8428             }
8429             }
8430              
8431             #
8432             # escape capture ($1, $2, $3, ...)
8433             #
8434 5379     641 0 10638 sub e_capture {
8435 641         2899  
8436             return join '', '${Egb18030::capture(', $_[0], ')}';
8437             return join '', '${', $_[0], '}';
8438             }
8439              
8440             #
8441             # escape transliteration (tr/// or y///)
8442 0     11 0 0 #
8443 11         55 sub e_tr {
8444 11   100     23 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
8445             my $e_tr = '';
8446 11         32 $modifier ||= '';
8447              
8448             $slash = 'div';
8449 11         13  
8450             # quote character class 1
8451             $charclass = q_tr($charclass);
8452 11         23  
8453             # quote character class 2
8454             $charclass2 = q_tr($charclass2);
8455 11 50       19  
8456 11 0       75 # /b /B modifier
8457 0         0 if ($modifier =~ tr/bB//d) {
8458             if ($variable eq '') {
8459             $e_tr = qq{tr$charclass$e$charclass2$modifier};
8460 0         0 }
8461             else {
8462             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
8463             }
8464 0 100       0 }
8465 11         23 else {
8466             if ($variable eq '') {
8467             $e_tr = qq{Egb18030::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
8468 2         5 }
8469             else {
8470             $e_tr = qq{Egb18030::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
8471             }
8472             }
8473 9         30  
8474 11         16 # clear tr/// variable
8475             $tr_variable = '';
8476 11         14 $bind_operator = '';
8477              
8478             return $e_tr;
8479             }
8480              
8481             #
8482             # quote for escape transliteration (tr/// or y///)
8483 11     22 0 70 #
8484             sub q_tr {
8485             my($charclass) = @_;
8486 22 50       34  
    0          
    0          
    0          
    0          
    0          
8487 22         54 # quote character class
8488             if ($charclass !~ /'/oxms) {
8489             return e_q('', "'", "'", $charclass); # --> q' '
8490 22         36 }
8491             elsif ($charclass !~ /\//oxms) {
8492             return e_q('q', '/', '/', $charclass); # --> q/ /
8493 0         0 }
8494             elsif ($charclass !~ /\#/oxms) {
8495             return e_q('q', '#', '#', $charclass); # --> q# #
8496 0         0 }
8497             elsif ($charclass !~ /[\<\>]/oxms) {
8498             return e_q('q', '<', '>', $charclass); # --> q< >
8499 0         0 }
8500             elsif ($charclass !~ /[\(\)]/oxms) {
8501             return e_q('q', '(', ')', $charclass); # --> q( )
8502 0         0 }
8503             elsif ($charclass !~ /[\{\}]/oxms) {
8504             return e_q('q', '{', '}', $charclass); # --> q{ }
8505 0         0 }
8506 0 0       0 else {
8507 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8508             if ($charclass !~ /\Q$char\E/xms) {
8509             return e_q('q', $char, $char, $charclass);
8510             }
8511             }
8512 0         0 }
8513              
8514             return e_q('q', '{', '}', $charclass);
8515             }
8516              
8517             #
8518             # escape q string (q//, '')
8519 0     4039 0 0 #
8520             sub e_q {
8521 4039         12142 my($ope,$delimiter,$end_delimiter,$string) = @_;
8522              
8523 4039         6897 $slash = 'div';
8524 4039         30675  
8525             my @char = $string =~ / \G (?>$q_char) /oxmsg;
8526             for (my $i=0; $i <= $#char; $i++) {
8527 4039 100 100     13140  
    100 100        
8528 21555         150862 # escape last octet of multiple-octet
8529             if ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
8530             $char[$i] = $1 . '\\' . $2;
8531 1         6 }
8532             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8533             $char[$i] = $1 . '\\' . $2;
8534 22 100 100     92 }
8535 4039         20475 }
8536             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8537             $char[-1] = $1 . '\\' . $2;
8538 204         644 }
8539 4039         24686  
8540             return join '', $ope, $delimiter, @char, $end_delimiter;
8541             return join '', $ope, $delimiter, $string, $end_delimiter;
8542             }
8543              
8544             #
8545             # escape qq string (qq//, "", qx//, ``)
8546 0     9646 0 0 #
8547             sub e_qq {
8548 9646         25277 my($ope,$delimiter,$end_delimiter,$string) = @_;
8549              
8550 9646         15028 $slash = 'div';
8551 9646         12176  
8552             my $left_e = 0;
8553             my $right_e = 0;
8554 9646         11172  
8555             # split regexp
8556             my @char = $string =~ /\G((?>
8557             [^\x81-\xFE\\\$]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
8558             \\x\{ (?>[0-9A-Fa-f]+) \} |
8559             \\o\{ (?>[0-7]+) \} |
8560             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8561             \\ $q_char |
8562             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8563             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8564             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8565             \$ (?>\s* [0-9]+) |
8566             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8567             \$ \$ (?![\w\{]) |
8568             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8569             $q_char
8570 9646         454860 ))/oxmsg;
8571              
8572             for (my $i=0; $i <= $#char; $i++) {
8573 9646 50 66     39987  
    50 33        
    100          
    100          
    50          
8574 311085         1134233 # "\L\u" --> "\u\L"
8575             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8576             @char[$i,$i+1] = @char[$i+1,$i];
8577             }
8578              
8579 0         0 # "\U\l" --> "\l\U"
8580             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8581             @char[$i,$i+1] = @char[$i+1,$i];
8582             }
8583              
8584 0         0 # octal escape sequence
8585             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8586             $char[$i] = Egb18030::octchr($1);
8587             }
8588              
8589 1         5 # hexadecimal escape sequence
8590             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8591             $char[$i] = Egb18030::hexchr($1);
8592             }
8593              
8594 1         4 # \N{CHARNAME} --> N{CHARNAME}
8595             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8596             $char[$i] = $1;
8597 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          
8598              
8599             if (0) {
8600             }
8601              
8602             # escape last octet of multiple-octet
8603 311085         3228845 # my $metachar = qr/[\@\\\|]/oxms; # '|' is for qx//, ``, open(), and system()
8604 0         0 # variable $delimiter and $end_delimiter can be ''
8605             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\@\\\|$delimiter$end_delimiter]) \z/xms) {
8606             $char[$i] = $1 . '\\' . $2;
8607             }
8608              
8609             # \F
8610             #
8611             # P.69 Table 2-6. Translation escapes
8612             # in Chapter 2: Bits and Pieces
8613             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8614             # (and so on)
8615              
8616 1342 50       4724 # \u \l \U \L \F \Q \E
8617 655         1692 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8618             if ($right_e < $left_e) {
8619             $char[$i] = '\\' . $char[$i];
8620             }
8621             }
8622             elsif ($char[$i] eq '\u') {
8623              
8624             # "STRING @{[ LIST EXPR ]} MORE STRING"
8625              
8626             # P.257 Other Tricks You Can Do with Hard References
8627             # in Chapter 8: References
8628             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
8629              
8630             # P.353 Other Tricks You Can Do with Hard References
8631             # in Chapter 8: References
8632             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8633              
8634 0         0 # (and so on)
8635 0         0  
8636             $char[$i] = '@{[Egb18030::ucfirst qq<';
8637             $left_e++;
8638 0         0 }
8639 0         0 elsif ($char[$i] eq '\l') {
8640             $char[$i] = '@{[Egb18030::lcfirst qq<';
8641             $left_e++;
8642 0         0 }
8643 0         0 elsif ($char[$i] eq '\U') {
8644             $char[$i] = '@{[Egb18030::uc qq<';
8645             $left_e++;
8646 0         0 }
8647 6         7 elsif ($char[$i] eq '\L') {
8648             $char[$i] = '@{[Egb18030::lc qq<';
8649             $left_e++;
8650 6         12 }
8651 9         20 elsif ($char[$i] eq '\F') {
8652             $char[$i] = '@{[Egb18030::fc qq<';
8653             $left_e++;
8654 9         18 }
8655 0         0 elsif ($char[$i] eq '\Q') {
8656             $char[$i] = '@{[CORE::quotemeta qq<';
8657             $left_e++;
8658 0 50       0 }
8659 12         25 elsif ($char[$i] eq '\E') {
8660 12         17 if ($right_e < $left_e) {
8661             $char[$i] = '>]}';
8662             $right_e++;
8663 12         23 }
8664             else {
8665             $char[$i] = '';
8666             }
8667 0         0 }
8668 0 0       0 elsif ($char[$i] eq '\Q') {
8669 0         0 while (1) {
8670             if (++$i > $#char) {
8671 0 0       0 last;
8672 0         0 }
8673             if ($char[$i] eq '\E') {
8674             last;
8675             }
8676             }
8677             }
8678             elsif ($char[$i] eq '\E') {
8679             }
8680              
8681             # $0 --> $0
8682             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8683             }
8684             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8685             }
8686              
8687             # $$ --> $$
8688             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8689             }
8690              
8691             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8692 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8693             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8694             $char[$i] = e_capture($1);
8695 417         1184 }
8696             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8697             $char[$i] = e_capture($1);
8698             }
8699              
8700 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8701             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8702             $char[$i] = e_capture($1.'->'.$2);
8703             }
8704              
8705 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8706             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8707             $char[$i] = e_capture($1.'->'.$2);
8708             }
8709              
8710 0         0 # $$foo
8711             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8712             $char[$i] = e_capture($1);
8713             }
8714              
8715 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egb18030::PREMATCH()
8716             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8717             $char[$i] = '@{[Egb18030::PREMATCH()]}';
8718             }
8719              
8720 44         146 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egb18030::MATCH()
8721             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8722             $char[$i] = '@{[Egb18030::MATCH()]}';
8723             }
8724              
8725 45         146 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egb18030::POSTMATCH()
8726             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8727             $char[$i] = '@{[Egb18030::POSTMATCH()]}';
8728             }
8729              
8730             # ${ foo } --> ${ foo }
8731             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8732             }
8733              
8734 33         109 # ${ ... }
8735             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8736             $char[$i] = e_capture($1);
8737             }
8738             }
8739 0 100       0  
8740 9646         21710 # return string
8741             if ($left_e > $right_e) {
8742 3         18 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
8743             }
8744             return join '', $ope, $delimiter, @char, $end_delimiter;
8745             }
8746              
8747             #
8748             # escape qw string (qw//)
8749 9643     34 0 85095 #
8750             sub e_qw {
8751 34         193 my($ope,$delimiter,$end_delimiter,$string) = @_;
8752              
8753             $slash = 'div';
8754 34         81  
  34         457  
8755 621 50       1046 # choice again delimiter
    0          
    0          
    0          
    0          
8756 34         186 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
8757             if (not $octet{$end_delimiter}) {
8758             return join '', $ope, $delimiter, $string, $end_delimiter;
8759 34         243 }
8760             elsif (not $octet{')'}) {
8761             return join '', $ope, '(', $string, ')';
8762 0         0 }
8763             elsif (not $octet{'}'}) {
8764             return join '', $ope, '{', $string, '}';
8765 0         0 }
8766             elsif (not $octet{']'}) {
8767             return join '', $ope, '[', $string, ']';
8768 0         0 }
8769             elsif (not $octet{'>'}) {
8770             return join '', $ope, '<', $string, '>';
8771 0         0 }
8772 0 0       0 else {
8773 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8774             if (not $octet{$char}) {
8775             return join '', $ope, $char, $string, $char;
8776             }
8777             }
8778             }
8779 0         0  
8780 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
8781 0         0 my @string = CORE::split(/\s+/, $string);
8782 0         0 for my $string (@string) {
8783 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
8784 0         0 for my $octet (@octet) {
8785             if ($octet =~ /\A (['\\]) \z/oxms) {
8786             $octet = '\\' . $1;
8787 0         0 }
8788             }
8789 0         0 $string = join '', @octet;
  0         0  
8790             }
8791             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
8792             }
8793              
8794             #
8795             # escape here document (<<"HEREDOC", <
8796 0     114 0 0 #
8797             sub e_heredoc {
8798 114         353 my($string) = @_;
8799              
8800 114         198 $slash = 'm//';
8801              
8802 114         395 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
8803 114         216  
8804             my $left_e = 0;
8805             my $right_e = 0;
8806 114         180  
8807             # split regexp
8808             my @char = $string =~ /\G((?>
8809             [^\x81-\xFE\\\$]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
8810             \\x\{ (?>[0-9A-Fa-f]+) \} |
8811             \\o\{ (?>[0-7]+) \} |
8812             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8813             \\ $q_char |
8814             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8815             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8816             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8817             \$ (?>\s* [0-9]+) |
8818             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8819             \$ \$ (?![\w\{]) |
8820             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8821             $q_char
8822 114         24334 ))/oxmsg;
8823              
8824             for (my $i=0; $i <= $#char; $i++) {
8825 114 50 66     878  
    50 33        
    100          
    100          
    50          
8826 3529         11619 # "\L\u" --> "\u\L"
8827             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8828             @char[$i,$i+1] = @char[$i+1,$i];
8829             }
8830              
8831 0         0 # "\U\l" --> "\l\U"
8832             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8833             @char[$i,$i+1] = @char[$i+1,$i];
8834             }
8835              
8836 0         0 # octal escape sequence
8837             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8838             $char[$i] = Egb18030::octchr($1);
8839             }
8840              
8841 1         3 # hexadecimal escape sequence
8842             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8843             $char[$i] = Egb18030::hexchr($1);
8844             }
8845              
8846 1         4 # \N{CHARNAME} --> N{CHARNAME}
8847             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8848             $char[$i] = $1;
8849 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          
8850              
8851             if (0) {
8852             }
8853 3529         32017  
8854 0         0 # escape character
8855             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
8856             $char[$i] = $1 . '\\' . $2;
8857             }
8858              
8859 57 50       233 # \u \l \U \L \F \Q \E
8860 144         272 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8861             if ($right_e < $left_e) {
8862             $char[$i] = '\\' . $char[$i];
8863             }
8864 0         0 }
8865 0         0 elsif ($char[$i] eq '\u') {
8866             $char[$i] = '@{[Egb18030::ucfirst qq<';
8867             $left_e++;
8868 0         0 }
8869 0         0 elsif ($char[$i] eq '\l') {
8870             $char[$i] = '@{[Egb18030::lcfirst qq<';
8871             $left_e++;
8872 0         0 }
8873 0         0 elsif ($char[$i] eq '\U') {
8874             $char[$i] = '@{[Egb18030::uc qq<';
8875             $left_e++;
8876 0         0 }
8877 6         9 elsif ($char[$i] eq '\L') {
8878             $char[$i] = '@{[Egb18030::lc qq<';
8879             $left_e++;
8880 6         10 }
8881 0         0 elsif ($char[$i] eq '\F') {
8882             $char[$i] = '@{[Egb18030::fc qq<';
8883             $left_e++;
8884 0         0 }
8885 0         0 elsif ($char[$i] eq '\Q') {
8886             $char[$i] = '@{[CORE::quotemeta qq<';
8887             $left_e++;
8888 0 50       0 }
8889 3         5 elsif ($char[$i] eq '\E') {
8890 3         6 if ($right_e < $left_e) {
8891             $char[$i] = '>]}';
8892             $right_e++;
8893 3         5 }
8894             else {
8895             $char[$i] = '';
8896             }
8897 0         0 }
8898 0 0       0 elsif ($char[$i] eq '\Q') {
8899 0         0 while (1) {
8900             if (++$i > $#char) {
8901 0 0       0 last;
8902 0         0 }
8903             if ($char[$i] eq '\E') {
8904             last;
8905             }
8906             }
8907             }
8908             elsif ($char[$i] eq '\E') {
8909             }
8910              
8911             # $0 --> $0
8912             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8913             }
8914             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8915             }
8916              
8917             # $$ --> $$
8918             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8919             }
8920              
8921             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8922 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8923             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8924             $char[$i] = e_capture($1);
8925 0         0 }
8926             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8927             $char[$i] = e_capture($1);
8928             }
8929              
8930 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8931             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8932             $char[$i] = e_capture($1.'->'.$2);
8933             }
8934              
8935 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8936             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8937             $char[$i] = e_capture($1.'->'.$2);
8938             }
8939              
8940 0         0 # $$foo
8941             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8942             $char[$i] = e_capture($1);
8943             }
8944              
8945 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egb18030::PREMATCH()
8946             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8947             $char[$i] = '@{[Egb18030::PREMATCH()]}';
8948             }
8949              
8950 8         60 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egb18030::MATCH()
8951             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8952             $char[$i] = '@{[Egb18030::MATCH()]}';
8953             }
8954              
8955 8         56 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egb18030::POSTMATCH()
8956             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8957             $char[$i] = '@{[Egb18030::POSTMATCH()]}';
8958             }
8959              
8960             # ${ foo } --> ${ foo }
8961             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8962             }
8963              
8964 6         42 # ${ ... }
8965             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8966             $char[$i] = e_capture($1);
8967             }
8968             }
8969 0 100       0  
8970 114         309 # return string
8971             if ($left_e > $right_e) {
8972 3         20 return join '', @char, '>]}' x ($left_e - $right_e);
8973             }
8974             return join '', @char;
8975             }
8976              
8977             #
8978             # escape regexp (m//, qr//)
8979 111     1843 0 951 #
8980 1843   100     8511 sub e_qr {
8981             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
8982 1843         6747 $modifier ||= '';
8983 1843 50       3795  
8984 1843         5135 $modifier =~ tr/p//d;
8985 0         0 if ($modifier =~ /([adlu])/oxms) {
8986 0 0       0 my $line = 0;
8987 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
8988 0         0 if ($filename ne __FILE__) {
8989             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
8990             last;
8991 0         0 }
8992             }
8993             die qq{Unsupported modifier "$1" used at line $line.\n};
8994 0         0 }
8995              
8996             $slash = 'div';
8997 1843 100       3004  
    100          
8998 1843         6019 # literal null string pattern
8999 8         9 if ($string eq '') {
9000 8         10 $modifier =~ tr/bB//d;
9001             $modifier =~ tr/i//d;
9002             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9003             }
9004              
9005             # /b /B modifier
9006             elsif ($modifier =~ tr/bB//d) {
9007 8 50       38  
9008 240         592 # choice again delimiter
9009 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
9010 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
9011 0         0 my %octet = map {$_ => 1} @char;
9012 0         0 if (not $octet{')'}) {
9013             $delimiter = '(';
9014             $end_delimiter = ')';
9015 0         0 }
9016 0         0 elsif (not $octet{'}'}) {
9017             $delimiter = '{';
9018             $end_delimiter = '}';
9019 0         0 }
9020 0         0 elsif (not $octet{']'}) {
9021             $delimiter = '[';
9022             $end_delimiter = ']';
9023 0         0 }
9024 0         0 elsif (not $octet{'>'}) {
9025             $delimiter = '<';
9026             $end_delimiter = '>';
9027 0         0 }
9028 0 0       0 else {
9029 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9030 0         0 if (not $octet{$char}) {
9031 0         0 $delimiter = $char;
9032             $end_delimiter = $char;
9033             last;
9034             }
9035             }
9036             }
9037 0 100 100     0 }
9038 240         1285  
9039             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9040             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
9041 90         493 }
9042             else {
9043             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9044             }
9045 150 100       852 }
9046 1595         4309  
9047             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9048             my $metachar = qr/[\@\\|[\]{^]/oxms;
9049 1595         6038  
9050             # split regexp
9051             my @char = $string =~ /\G((?>
9052             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
9053             \\x (?>[0-9A-Fa-f]{1,2}) |
9054             \\ (?>[0-7]{2,3}) |
9055             \\c [\x40-\x5F] |
9056             \\x\{ (?>[0-9A-Fa-f]+) \} |
9057             \\o\{ (?>[0-7]+) \} |
9058             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9059             \\ $q_char |
9060             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9061             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9062             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9063             [\$\@] $qq_variable |
9064             \$ (?>\s* [0-9]+) |
9065             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9066             \$ \$ (?![\w\{]) |
9067             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9068             \[\^ |
9069             \[\: (?>[a-z]+) :\] |
9070             \[\:\^ (?>[a-z]+) :\] |
9071             \(\? |
9072             $q_char
9073             ))/oxmsg;
9074 1595 50       184284  
9075 1595         8590 # choice again delimiter
  0         0  
9076 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9077 0         0 my %octet = map {$_ => 1} @char;
9078 0         0 if (not $octet{')'}) {
9079             $delimiter = '(';
9080             $end_delimiter = ')';
9081 0         0 }
9082 0         0 elsif (not $octet{'}'}) {
9083             $delimiter = '{';
9084             $end_delimiter = '}';
9085 0         0 }
9086 0         0 elsif (not $octet{']'}) {
9087             $delimiter = '[';
9088             $end_delimiter = ']';
9089 0         0 }
9090 0         0 elsif (not $octet{'>'}) {
9091             $delimiter = '<';
9092             $end_delimiter = '>';
9093 0         0 }
9094 0 0       0 else {
9095 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9096 0         0 if (not $octet{$char}) {
9097 0         0 $delimiter = $char;
9098             $end_delimiter = $char;
9099             last;
9100             }
9101             }
9102             }
9103 0         0 }
9104 1595         2778  
9105 1595         2421 my $left_e = 0;
9106             my $right_e = 0;
9107             for (my $i=0; $i <= $#char; $i++) {
9108 1595 50 66     4719  
    50 66        
    100          
    100          
    100          
    100          
9109 5546         32429 # "\L\u" --> "\u\L"
9110             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9111             @char[$i,$i+1] = @char[$i+1,$i];
9112             }
9113              
9114 0         0 # "\U\l" --> "\l\U"
9115             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9116             @char[$i,$i+1] = @char[$i+1,$i];
9117             }
9118              
9119 0         0 # octal escape sequence
9120             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9121             $char[$i] = Egb18030::octchr($1);
9122             }
9123              
9124 1         4 # hexadecimal escape sequence
9125             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9126             $char[$i] = Egb18030::hexchr($1);
9127             }
9128              
9129             # \b{...} --> b\{...}
9130             # \B{...} --> B\{...}
9131             # \N{CHARNAME} --> N\{CHARNAME}
9132             # \p{PROPERTY} --> p\{PROPERTY}
9133 1         3 # \P{PROPERTY} --> P\{PROPERTY}
9134             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9135             $char[$i] = $1 . '\\' . $2;
9136             }
9137              
9138 6         21 # \p, \P, \X --> p, P, X
9139             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9140             $char[$i] = $1;
9141 4 100 100     13 }
    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          
9142              
9143             if (0) {
9144             }
9145 5546         40926  
9146 0         0 # escape last octet of multiple-octet
9147             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9148             $char[$i] = $1 . '\\' . $2;
9149             }
9150              
9151 77 50 33     340 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
9152 6         133 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9153             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)) {
9154             $char[$i] .= join '', splice @char, $i+1, 3;
9155 0         0 }
9156             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)) {
9157             $char[$i] .= join '', splice @char, $i+1, 2;
9158 0         0 }
9159             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)) {
9160             $char[$i] .= join '', splice @char, $i+1, 1;
9161             }
9162             }
9163              
9164 0         0 # open character class [...]
9165             elsif ($char[$i] eq '[') {
9166             my $left = $i;
9167              
9168             # [] make die "Unmatched [] in regexp ...\n"
9169 594 100       1270 # (and so on)
9170 594         1527  
9171             if ($char[$i+1] eq ']') {
9172             $i++;
9173 3         5 }
9174 594 50       852  
9175 2615         4038 while (1) {
9176             if (++$i > $#char) {
9177 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9178 2615         4569 }
9179             if ($char[$i] eq ']') {
9180             my $right = $i;
9181 594 100       839  
9182 594         19390 # [...]
  90         198  
9183             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9184             splice @char, $left, $right-$left+1, sprintf(q{@{[Egb18030::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9185 270         545 }
9186             else {
9187             splice @char, $left, $right-$left+1, Egb18030::charlist_qr(@char[$left+1..$right-1], $modifier);
9188 504         2506 }
9189 594         1238  
9190             $i = $left;
9191             last;
9192             }
9193             }
9194             }
9195              
9196 594         1698 # open character class [^...]
9197             elsif ($char[$i] eq '[^') {
9198             my $left = $i;
9199              
9200             # [^] make die "Unmatched [] in regexp ...\n"
9201 328 100       1067 # (and so on)
9202 328         945  
9203             if ($char[$i+1] eq ']') {
9204             $i++;
9205 5         49 }
9206 328 50       471  
9207 1447         2210 while (1) {
9208             if (++$i > $#char) {
9209 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9210 1447         2998 }
9211             if ($char[$i] eq ']') {
9212             my $right = $i;
9213 328 100       412  
9214 328         3066 # [^...]
  90         231  
9215             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9216             splice @char, $left, $right-$left+1, sprintf(q{@{[Egb18030::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9217 270         576 }
9218             else {
9219             splice @char, $left, $right-$left+1, Egb18030::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9220 238         1680 }
9221 328         695  
9222             $i = $left;
9223             last;
9224             }
9225             }
9226             }
9227              
9228 328         957 # rewrite character class or escape character
9229             elsif (my $char = character_class($char[$i],$modifier)) {
9230             $char[$i] = $char;
9231             }
9232              
9233 215 50       613 # /i modifier
9234 238         448 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egb18030::uc($char[$i]) ne Egb18030::fc($char[$i]))) {
9235             if (CORE::length(Egb18030::fc($char[$i])) == 1) {
9236             $char[$i] = '[' . Egb18030::uc($char[$i]) . Egb18030::fc($char[$i]) . ']';
9237 238         532 }
9238             else {
9239             $char[$i] = '(?:' . Egb18030::uc($char[$i]) . '|' . Egb18030::fc($char[$i]) . ')';
9240             }
9241             }
9242              
9243 0 50       0 # \u \l \U \L \F \Q \E
9244 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9245             if ($right_e < $left_e) {
9246             $char[$i] = '\\' . $char[$i];
9247             }
9248 0         0 }
9249 0         0 elsif ($char[$i] eq '\u') {
9250             $char[$i] = '@{[Egb18030::ucfirst qq<';
9251             $left_e++;
9252 0         0 }
9253 0         0 elsif ($char[$i] eq '\l') {
9254             $char[$i] = '@{[Egb18030::lcfirst qq<';
9255             $left_e++;
9256 0         0 }
9257 1         3 elsif ($char[$i] eq '\U') {
9258             $char[$i] = '@{[Egb18030::uc qq<';
9259             $left_e++;
9260 1         4 }
9261 1         2 elsif ($char[$i] eq '\L') {
9262             $char[$i] = '@{[Egb18030::lc qq<';
9263             $left_e++;
9264 1         3 }
9265 9         16 elsif ($char[$i] eq '\F') {
9266             $char[$i] = '@{[Egb18030::fc qq<';
9267             $left_e++;
9268 9         20 }
9269 22         47 elsif ($char[$i] eq '\Q') {
9270             $char[$i] = '@{[CORE::quotemeta qq<';
9271             $left_e++;
9272 22 50       55 }
9273 33         80 elsif ($char[$i] eq '\E') {
9274 33         52 if ($right_e < $left_e) {
9275             $char[$i] = '>]}';
9276             $right_e++;
9277 33         81 }
9278             else {
9279             $char[$i] = '';
9280             }
9281 0         0 }
9282 0 0       0 elsif ($char[$i] eq '\Q') {
9283 0         0 while (1) {
9284             if (++$i > $#char) {
9285 0 0       0 last;
9286 0         0 }
9287             if ($char[$i] eq '\E') {
9288             last;
9289             }
9290             }
9291             }
9292             elsif ($char[$i] eq '\E') {
9293             }
9294              
9295 0 0       0 # $0 --> $0
9296 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9297             if ($ignorecase) {
9298             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
9299             }
9300 0 0       0 }
9301 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9302             if ($ignorecase) {
9303             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
9304             }
9305             }
9306              
9307             # $$ --> $$
9308             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9309             }
9310              
9311             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9312 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9313 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9314 0         0 $char[$i] = e_capture($1);
9315             if ($ignorecase) {
9316             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
9317             }
9318 0         0 }
9319 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9320 0         0 $char[$i] = e_capture($1);
9321             if ($ignorecase) {
9322             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
9323             }
9324             }
9325              
9326 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
9327 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) {
9328 0         0 $char[$i] = e_capture($1.'->'.$2);
9329             if ($ignorecase) {
9330             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
9331             }
9332             }
9333              
9334 0         0 # $$foo{ ... } --> $ $foo->{ ... }
9335 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) {
9336 0         0 $char[$i] = e_capture($1.'->'.$2);
9337             if ($ignorecase) {
9338             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
9339             }
9340             }
9341              
9342 0         0 # $$foo
9343 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
9344 0         0 $char[$i] = e_capture($1);
9345             if ($ignorecase) {
9346             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
9347             }
9348             }
9349              
9350 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egb18030::PREMATCH()
9351 8         25 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
9352             if ($ignorecase) {
9353             $char[$i] = '@{[Egb18030::ignorecase(Egb18030::PREMATCH())]}';
9354 0         0 }
9355             else {
9356             $char[$i] = '@{[Egb18030::PREMATCH()]}';
9357             }
9358             }
9359              
9360 8 50       28 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egb18030::MATCH()
9361 8         23 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
9362             if ($ignorecase) {
9363             $char[$i] = '@{[Egb18030::ignorecase(Egb18030::MATCH())]}';
9364 0         0 }
9365             else {
9366             $char[$i] = '@{[Egb18030::MATCH()]}';
9367             }
9368             }
9369              
9370 8 50       29 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egb18030::POSTMATCH()
9371 6         18 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
9372             if ($ignorecase) {
9373             $char[$i] = '@{[Egb18030::ignorecase(Egb18030::POSTMATCH())]}';
9374 0         0 }
9375             else {
9376             $char[$i] = '@{[Egb18030::POSTMATCH()]}';
9377             }
9378             }
9379              
9380 6 0       21 # ${ foo }
9381 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) {
9382             if ($ignorecase) {
9383             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
9384             }
9385             }
9386              
9387 0         0 # ${ ... }
9388 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
9389 0         0 $char[$i] = e_capture($1);
9390             if ($ignorecase) {
9391             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
9392             }
9393             }
9394              
9395 0         0 # $scalar or @array
9396 31 100       144 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
9397 31         109 $char[$i] = e_string($char[$i]);
9398             if ($ignorecase) {
9399             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
9400             }
9401             }
9402              
9403 4 100 66     15 # quote character before ? + * {
    50          
9404             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9405             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
9406 196         2920 }
9407 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9408 0         0 my $char = $char[$i-1];
9409             if ($char[$i] eq '{') {
9410             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
9411 0         0 }
9412             else {
9413             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
9414             }
9415 0         0 }
9416             else {
9417             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9418             }
9419             }
9420             }
9421 195         866  
9422 1595 50       3251 # make regexp string
9423 1595 0 0     3895 $modifier =~ tr/i//d;
9424 0         0 if ($left_e > $right_e) {
9425             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9426             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
9427 0         0 }
9428             else {
9429             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
9430 0 100 100     0 }
9431 1595         9792 }
9432             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9433             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
9434 94         763 }
9435             else {
9436             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9437             }
9438             }
9439              
9440             #
9441             # double quote stuff
9442 1501     540 0 15529 #
9443             sub qq_stuff {
9444             my($delimiter,$end_delimiter,$stuff) = @_;
9445 540 100       991  
9446 540         1350 # scalar variable or array variable
9447             if ($stuff =~ /\A [\$\@] /oxms) {
9448             return $stuff;
9449             }
9450 300         1149  
  240         591  
9451 280         830 # quote by delimiter
9452 240 50       617 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
9453 240 50       418 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9454 240 50       367 next if $char eq $delimiter;
9455 240         436 next if $char eq $end_delimiter;
9456             if (not $octet{$char}) {
9457             return join '', 'qq', $char, $stuff, $char;
9458 240         955 }
9459             }
9460             return join '', 'qq', '<', $stuff, '>';
9461             }
9462              
9463             #
9464             # escape regexp (m'', qr'', and m''b, qr''b)
9465 0     163 0 0 #
9466 163   100     816 sub e_qr_q {
9467             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9468 163         518 $modifier ||= '';
9469 163 50       352  
9470 163         466 $modifier =~ tr/p//d;
9471 0         0 if ($modifier =~ /([adlu])/oxms) {
9472 0 0       0 my $line = 0;
9473 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9474 0         0 if ($filename ne __FILE__) {
9475             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9476             last;
9477 0         0 }
9478             }
9479             die qq{Unsupported modifier "$1" used at line $line.\n};
9480 0         0 }
9481              
9482             $slash = 'div';
9483 163 100       231  
    100          
9484 163         382 # literal null string pattern
9485 8         8 if ($string eq '') {
9486 8         10 $modifier =~ tr/bB//d;
9487             $modifier =~ tr/i//d;
9488             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9489             }
9490              
9491 8         37 # with /b /B modifier
9492             elsif ($modifier =~ tr/bB//d) {
9493             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
9494             }
9495              
9496 89         254 # without /b /B modifier
9497             else {
9498             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
9499             }
9500             }
9501              
9502             #
9503             # escape regexp (m'', qr'')
9504 66     66 0 136 #
9505             sub e_qr_qt {
9506 66 100       146 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9507              
9508             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9509 66         154  
9510             # split regexp
9511             my @char = $string =~ /\G((?>
9512             [^\x81-\xFE\\\[\$\@\/] |
9513             [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
9514             \[\^ |
9515             \[\: (?>[a-z]+) \:\] |
9516             \[\:\^ (?>[a-z]+) \:\] |
9517             [\$\@\/] |
9518             \\ (?:$q_char) |
9519             (?:$q_char)
9520             ))/oxmsg;
9521 66         821  
9522 66 100 100     191 # unescape character
    50 100        
    50 66        
    50          
    50          
    100          
    50          
9523             for (my $i=0; $i <= $#char; $i++) {
9524             if (0) {
9525             }
9526 79         759  
9527 0         0 # escape last octet of multiple-octet
9528             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9529             $char[$i] = $1 . '\\' . $2;
9530             }
9531              
9532 2         13 # open character class [...]
9533 0 0       0 elsif ($char[$i] eq '[') {
9534 0         0 my $left = $i;
9535             if ($char[$i+1] eq ']') {
9536 0         0 $i++;
9537 0 0       0 }
9538 0         0 while (1) {
9539             if (++$i > $#char) {
9540 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9541 0         0 }
9542             if ($char[$i] eq ']') {
9543             my $right = $i;
9544 0         0  
9545             # [...]
9546 0         0 splice @char, $left, $right-$left+1, Egb18030::charlist_qr(@char[$left+1..$right-1], $modifier);
9547 0         0  
9548             $i = $left;
9549             last;
9550             }
9551             }
9552             }
9553              
9554 0         0 # open character class [^...]
9555 0 0       0 elsif ($char[$i] eq '[^') {
9556 0         0 my $left = $i;
9557             if ($char[$i+1] eq ']') {
9558 0         0 $i++;
9559 0 0       0 }
9560 0         0 while (1) {
9561             if (++$i > $#char) {
9562 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9563 0         0 }
9564             if ($char[$i] eq ']') {
9565             my $right = $i;
9566 0         0  
9567             # [^...]
9568 0         0 splice @char, $left, $right-$left+1, Egb18030::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9569 0         0  
9570             $i = $left;
9571             last;
9572             }
9573             }
9574             }
9575              
9576 0         0 # escape $ @ / and \
9577             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9578             $char[$i] = '\\' . $char[$i];
9579             }
9580              
9581 0         0 # rewrite character class or escape character
9582             elsif (my $char = character_class($char[$i],$modifier)) {
9583             $char[$i] = $char;
9584             }
9585              
9586 0 50       0 # /i modifier
9587 16         37 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egb18030::uc($char[$i]) ne Egb18030::fc($char[$i]))) {
9588             if (CORE::length(Egb18030::fc($char[$i])) == 1) {
9589             $char[$i] = '[' . Egb18030::uc($char[$i]) . Egb18030::fc($char[$i]) . ']';
9590 16         43 }
9591             else {
9592             $char[$i] = '(?:' . Egb18030::uc($char[$i]) . '|' . Egb18030::fc($char[$i]) . ')';
9593             }
9594             }
9595              
9596 0 0       0 # quote character before ? + * {
9597             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9598             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
9599 0         0 }
9600             else {
9601             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9602             }
9603             }
9604 0         0 }
9605 66         111  
9606             $delimiter = '/';
9607 66         83 $end_delimiter = '/';
9608 66         91  
9609             $modifier =~ tr/i//d;
9610             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9611             }
9612              
9613             #
9614             # escape regexp (m''b, qr''b)
9615 66     89 0 428 #
9616             sub e_qr_qb {
9617             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9618 89         198  
9619             # split regexp
9620             my @char = $string =~ /\G ((?>[^\\]|\\\\|[\x00-\xFF])) /oxmsg;
9621 89         388  
9622 89 50       248 # unescape character
    50          
9623             for (my $i=0; $i <= $#char; $i++) {
9624             if (0) {
9625             }
9626 199         672  
9627             # remain \\
9628             elsif ($char[$i] eq '\\\\') {
9629             }
9630              
9631 0         0 # escape $ @ / and \
9632             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9633             $char[$i] = '\\' . $char[$i];
9634             }
9635 0         0 }
9636 89         135  
9637 89         112 $delimiter = '/';
9638             $end_delimiter = '/';
9639             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9640             }
9641              
9642             #
9643             # escape regexp (s/here//)
9644 89     196 0 539 #
9645 196   100     618 sub e_s1 {
9646             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9647 196         774 $modifier ||= '';
9648 196 50       305  
9649 196         893 $modifier =~ tr/p//d;
9650 0         0 if ($modifier =~ /([adlu])/oxms) {
9651 0 0       0 my $line = 0;
9652 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9653 0         0 if ($filename ne __FILE__) {
9654             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9655             last;
9656 0         0 }
9657             }
9658             die qq{Unsupported modifier "$1" used at line $line.\n};
9659 0         0 }
9660              
9661             $slash = 'div';
9662 196 100       731  
    100          
9663 196         716 # literal null string pattern
9664 8         10 if ($string eq '') {
9665 8         11 $modifier =~ tr/bB//d;
9666             $modifier =~ tr/i//d;
9667             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9668             }
9669              
9670             # /b /B modifier
9671             elsif ($modifier =~ tr/bB//d) {
9672 8 50       46  
9673 44         124 # choice again delimiter
9674 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
9675 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
9676 0         0 my %octet = map {$_ => 1} @char;
9677 0         0 if (not $octet{')'}) {
9678             $delimiter = '(';
9679             $end_delimiter = ')';
9680 0         0 }
9681 0         0 elsif (not $octet{'}'}) {
9682             $delimiter = '{';
9683             $end_delimiter = '}';
9684 0         0 }
9685 0         0 elsif (not $octet{']'}) {
9686             $delimiter = '[';
9687             $end_delimiter = ']';
9688 0         0 }
9689 0         0 elsif (not $octet{'>'}) {
9690             $delimiter = '<';
9691             $end_delimiter = '>';
9692 0         0 }
9693 0 0       0 else {
9694 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9695 0         0 if (not $octet{$char}) {
9696 0         0 $delimiter = $char;
9697             $end_delimiter = $char;
9698             last;
9699             }
9700             }
9701             }
9702 0         0 }
9703 44         64  
9704 44         57 my $prematch = '';
9705             $prematch = q{(\G[\x00-\xFF]*?)};
9706             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9707 44 100       295 }
9708 144         558  
9709             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9710             my $metachar = qr/[\@\\|[\]{^]/oxms;
9711 144         1626  
9712             # split regexp
9713             my @char = $string =~ /\G((?>
9714             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
9715             \\ (?>[1-9][0-9]*) |
9716             \\g (?>\s*) (?>[1-9][0-9]*) |
9717             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9718             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9719             \\x (?>[0-9A-Fa-f]{1,2}) |
9720             \\ (?>[0-7]{2,3}) |
9721             \\c [\x40-\x5F] |
9722             \\x\{ (?>[0-9A-Fa-f]+) \} |
9723             \\o\{ (?>[0-7]+) \} |
9724             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9725             \\ $q_char |
9726             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9727             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9728             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9729             [\$\@] $qq_variable |
9730             \$ (?>\s* [0-9]+) |
9731             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9732             \$ \$ (?![\w\{]) |
9733             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9734             \[\^ |
9735             \[\: (?>[a-z]+) :\] |
9736             \[\:\^ (?>[a-z]+) :\] |
9737             \(\? |
9738             $q_char
9739             ))/oxmsg;
9740 144 50       47368  
9741 144         1706 # choice again delimiter
  0         0  
9742 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9743 0         0 my %octet = map {$_ => 1} @char;
9744 0         0 if (not $octet{')'}) {
9745             $delimiter = '(';
9746             $end_delimiter = ')';
9747 0         0 }
9748 0         0 elsif (not $octet{'}'}) {
9749             $delimiter = '{';
9750             $end_delimiter = '}';
9751 0         0 }
9752 0         0 elsif (not $octet{']'}) {
9753             $delimiter = '[';
9754             $end_delimiter = ']';
9755 0         0 }
9756 0         0 elsif (not $octet{'>'}) {
9757             $delimiter = '<';
9758             $end_delimiter = '>';
9759 0         0 }
9760 0 0       0 else {
9761 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9762 0         0 if (not $octet{$char}) {
9763 0         0 $delimiter = $char;
9764             $end_delimiter = $char;
9765             last;
9766             }
9767             }
9768             }
9769             }
9770 0         0  
  144         336  
9771             # count '('
9772 500         1041 my $parens = grep { $_ eq '(' } @char;
9773 144         241  
9774 144         248 my $left_e = 0;
9775             my $right_e = 0;
9776             for (my $i=0; $i <= $#char; $i++) {
9777 144 50 33     499  
    50 33        
    100          
    100          
    50          
    50          
9778 421         3076 # "\L\u" --> "\u\L"
9779             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9780             @char[$i,$i+1] = @char[$i+1,$i];
9781             }
9782              
9783 0         0 # "\U\l" --> "\l\U"
9784             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9785             @char[$i,$i+1] = @char[$i+1,$i];
9786             }
9787              
9788 0         0 # octal escape sequence
9789             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9790             $char[$i] = Egb18030::octchr($1);
9791             }
9792              
9793 1         3 # hexadecimal escape sequence
9794             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9795             $char[$i] = Egb18030::hexchr($1);
9796             }
9797              
9798             # \b{...} --> b\{...}
9799             # \B{...} --> B\{...}
9800             # \N{CHARNAME} --> N\{CHARNAME}
9801             # \p{PROPERTY} --> p\{PROPERTY}
9802 1         3 # \P{PROPERTY} --> P\{PROPERTY}
9803             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9804             $char[$i] = $1 . '\\' . $2;
9805             }
9806              
9807 0         0 # \p, \P, \X --> p, P, X
9808             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9809             $char[$i] = $1;
9810 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          
9811              
9812             if (0) {
9813             }
9814 421         4922  
9815 0         0 # escape last octet of multiple-octet
9816             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9817             $char[$i] = $1 . '\\' . $2;
9818             }
9819              
9820 23 0 0     159 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
9821 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9822             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)) {
9823             $char[$i] .= join '', splice @char, $i+1, 3;
9824 0         0 }
9825             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)) {
9826             $char[$i] .= join '', splice @char, $i+1, 2;
9827 0         0 }
9828             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)) {
9829             $char[$i] .= join '', splice @char, $i+1, 1;
9830             }
9831             }
9832              
9833 0         0 # open character class [...]
9834 20 50       43 elsif ($char[$i] eq '[') {
9835 20         67 my $left = $i;
9836             if ($char[$i+1] eq ']') {
9837 0         0 $i++;
9838 20 50       31 }
9839 79         128 while (1) {
9840             if (++$i > $#char) {
9841 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9842 79         250 }
9843             if ($char[$i] eq ']') {
9844             my $right = $i;
9845 20 50       51  
9846 20         148 # [...]
  0         0  
9847             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9848             splice @char, $left, $right-$left+1, sprintf(q{@{[Egb18030::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9849 0         0 }
9850             else {
9851             splice @char, $left, $right-$left+1, Egb18030::charlist_qr(@char[$left+1..$right-1], $modifier);
9852 20         110 }
9853 20         39  
9854             $i = $left;
9855             last;
9856             }
9857             }
9858             }
9859              
9860 20         69 # open character class [^...]
9861 0 0       0 elsif ($char[$i] eq '[^') {
9862 0         0 my $left = $i;
9863             if ($char[$i+1] eq ']') {
9864 0         0 $i++;
9865 0 0       0 }
9866 0         0 while (1) {
9867             if (++$i > $#char) {
9868 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9869 0         0 }
9870             if ($char[$i] eq ']') {
9871             my $right = $i;
9872 0 0       0  
9873 0         0 # [^...]
  0         0  
9874             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9875             splice @char, $left, $right-$left+1, sprintf(q{@{[Egb18030::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9876 0         0 }
9877             else {
9878             splice @char, $left, $right-$left+1, Egb18030::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9879 0         0 }
9880 0         0  
9881             $i = $left;
9882             last;
9883             }
9884             }
9885             }
9886              
9887 0         0 # rewrite character class or escape character
9888             elsif (my $char = character_class($char[$i],$modifier)) {
9889             $char[$i] = $char;
9890             }
9891              
9892 11 50       29 # /i modifier
9893 11         25 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egb18030::uc($char[$i]) ne Egb18030::fc($char[$i]))) {
9894             if (CORE::length(Egb18030::fc($char[$i])) == 1) {
9895             $char[$i] = '[' . Egb18030::uc($char[$i]) . Egb18030::fc($char[$i]) . ']';
9896 11         22 }
9897             else {
9898             $char[$i] = '(?:' . Egb18030::uc($char[$i]) . '|' . Egb18030::fc($char[$i]) . ')';
9899             }
9900             }
9901              
9902 0 50       0 # \u \l \U \L \F \Q \E
9903 16         50 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9904             if ($right_e < $left_e) {
9905             $char[$i] = '\\' . $char[$i];
9906             }
9907 0         0 }
9908 0         0 elsif ($char[$i] eq '\u') {
9909             $char[$i] = '@{[Egb18030::ucfirst qq<';
9910             $left_e++;
9911 0         0 }
9912 0         0 elsif ($char[$i] eq '\l') {
9913             $char[$i] = '@{[Egb18030::lcfirst qq<';
9914             $left_e++;
9915 0         0 }
9916 0         0 elsif ($char[$i] eq '\U') {
9917             $char[$i] = '@{[Egb18030::uc qq<';
9918             $left_e++;
9919 0         0 }
9920 0         0 elsif ($char[$i] eq '\L') {
9921             $char[$i] = '@{[Egb18030::lc qq<';
9922             $left_e++;
9923 0         0 }
9924 0         0 elsif ($char[$i] eq '\F') {
9925             $char[$i] = '@{[Egb18030::fc qq<';
9926             $left_e++;
9927 0         0 }
9928 7         13 elsif ($char[$i] eq '\Q') {
9929             $char[$i] = '@{[CORE::quotemeta qq<';
9930             $left_e++;
9931 7 50       17 }
9932 7         18 elsif ($char[$i] eq '\E') {
9933 7         12 if ($right_e < $left_e) {
9934             $char[$i] = '>]}';
9935             $right_e++;
9936 7         16 }
9937             else {
9938             $char[$i] = '';
9939             }
9940 0         0 }
9941 0 0       0 elsif ($char[$i] eq '\Q') {
9942 0         0 while (1) {
9943             if (++$i > $#char) {
9944 0 0       0 last;
9945 0         0 }
9946             if ($char[$i] eq '\E') {
9947             last;
9948             }
9949             }
9950             }
9951             elsif ($char[$i] eq '\E') {
9952             }
9953              
9954             # \0 --> \0
9955             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
9956             }
9957              
9958             # \g{N}, \g{-N}
9959              
9960             # P.108 Using Simple Patterns
9961             # in Chapter 7: In the World of Regular Expressions
9962             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
9963              
9964             # P.221 Capturing
9965             # in Chapter 5: Pattern Matching
9966             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
9967              
9968             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
9969             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9970             }
9971              
9972 0 0       0 # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
9973 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9974             if ($1 <= $parens) {
9975             $char[$i] = '\\g{' . ($1 + 1) . '}';
9976             }
9977             }
9978              
9979 0 0       0 # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
9980 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9981             if ($1 <= $parens) {
9982             $char[$i] = '\\g' . ($1 + 1);
9983             }
9984             }
9985              
9986 0 0       0 # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
9987 0         0 elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9988             if ($1 <= $parens) {
9989             $char[$i] = '\\' . ($1 + 1);
9990             }
9991             }
9992              
9993 0 0       0 # $0 --> $0
9994 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9995             if ($ignorecase) {
9996             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
9997             }
9998 0 0       0 }
9999 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
10000             if ($ignorecase) {
10001             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10002             }
10003             }
10004              
10005             # $$ --> $$
10006             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10007             }
10008              
10009             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10010 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
10011 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10012 0         0 $char[$i] = e_capture($1);
10013             if ($ignorecase) {
10014             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10015             }
10016 0         0 }
10017 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10018 0         0 $char[$i] = e_capture($1);
10019             if ($ignorecase) {
10020             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10021             }
10022             }
10023              
10024 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10025 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) {
10026 0         0 $char[$i] = e_capture($1.'->'.$2);
10027             if ($ignorecase) {
10028             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10029             }
10030             }
10031              
10032 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10033 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) {
10034 0         0 $char[$i] = e_capture($1.'->'.$2);
10035             if ($ignorecase) {
10036             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10037             }
10038             }
10039              
10040 0         0 # $$foo
10041 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10042 0         0 $char[$i] = e_capture($1);
10043             if ($ignorecase) {
10044             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10045             }
10046             }
10047              
10048 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egb18030::PREMATCH()
10049 4         18 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10050             if ($ignorecase) {
10051             $char[$i] = '@{[Egb18030::ignorecase(Egb18030::PREMATCH())]}';
10052 0         0 }
10053             else {
10054             $char[$i] = '@{[Egb18030::PREMATCH()]}';
10055             }
10056             }
10057              
10058 4 50       16 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egb18030::MATCH()
10059 4         15 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10060             if ($ignorecase) {
10061             $char[$i] = '@{[Egb18030::ignorecase(Egb18030::MATCH())]}';
10062 0         0 }
10063             else {
10064             $char[$i] = '@{[Egb18030::MATCH()]}';
10065             }
10066             }
10067              
10068 4 50       17 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egb18030::POSTMATCH()
10069 3         13 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10070             if ($ignorecase) {
10071             $char[$i] = '@{[Egb18030::ignorecase(Egb18030::POSTMATCH())]}';
10072 0         0 }
10073             else {
10074             $char[$i] = '@{[Egb18030::POSTMATCH()]}';
10075             }
10076             }
10077              
10078 3 0       13 # ${ foo }
10079 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) {
10080             if ($ignorecase) {
10081             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10082             }
10083             }
10084              
10085 0         0 # ${ ... }
10086 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10087 0         0 $char[$i] = e_capture($1);
10088             if ($ignorecase) {
10089             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10090             }
10091             }
10092              
10093 0         0 # $scalar or @array
10094 13 50       48 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10095 13         112 $char[$i] = e_string($char[$i]);
10096             if ($ignorecase) {
10097             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10098             }
10099             }
10100              
10101 0 50       0 # quote character before ? + * {
10102             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10103             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10104 23         131 }
10105             else {
10106             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10107             }
10108             }
10109             }
10110 23         134  
10111 144         350 # make regexp string
10112 144         408 my $prematch = '';
10113 144 50       248 $prematch = "($anchor)";
10114 144         372 $modifier =~ tr/i//d;
10115             if ($left_e > $right_e) {
10116 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
10117             }
10118             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10119             }
10120              
10121             #
10122             # escape regexp (s'here'' or s'here''b)
10123 144     96 0 1835 #
10124 96   100     304 sub e_s1_q {
10125             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10126 96         309 $modifier ||= '';
10127 96 50       213  
10128 96         252 $modifier =~ tr/p//d;
10129 0         0 if ($modifier =~ /([adlu])/oxms) {
10130 0 0       0 my $line = 0;
10131 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10132 0         0 if ($filename ne __FILE__) {
10133             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10134             last;
10135 0         0 }
10136             }
10137             die qq{Unsupported modifier "$1" used at line $line.\n};
10138 0         0 }
10139              
10140             $slash = 'div';
10141 96 100       216  
    100          
10142 96         299 # literal null string pattern
10143 8         9 if ($string eq '') {
10144 8         9 $modifier =~ tr/bB//d;
10145             $modifier =~ tr/i//d;
10146             return join '', $ope, $delimiter, $end_delimiter, $modifier;
10147             }
10148              
10149 8         43 # with /b /B modifier
10150             elsif ($modifier =~ tr/bB//d) {
10151             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
10152             }
10153              
10154 44         139 # without /b /B modifier
10155             else {
10156             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
10157             }
10158             }
10159              
10160             #
10161             # escape regexp (s'here'')
10162 44     44 0 135 #
10163             sub e_s1_qt {
10164 44 100       140 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10165              
10166             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10167 44         131  
10168             # split regexp
10169             my @char = $string =~ /\G((?>
10170             [^\x81-\xFE\\\[\$\@\/] |
10171             [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
10172             \[\^ |
10173             \[\: (?>[a-z]+) \:\] |
10174             \[\:\^ (?>[a-z]+) \:\] |
10175             [\$\@\/] |
10176             \\ (?:$q_char) |
10177             (?:$q_char)
10178             ))/oxmsg;
10179 44         1831  
10180 44 50 100     186 # unescape character
    50 100        
    50 66        
    50          
    100          
    100          
    50          
10181             for (my $i=0; $i <= $#char; $i++) {
10182             if (0) {
10183             }
10184 62         799  
10185 0         0 # escape last octet of multiple-octet
10186             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10187             $char[$i] = $1 . '\\' . $2;
10188             }
10189              
10190 0         0 # open character class [...]
10191 0 0       0 elsif ($char[$i] eq '[') {
10192 0         0 my $left = $i;
10193             if ($char[$i+1] eq ']') {
10194 0         0 $i++;
10195 0 0       0 }
10196 0         0 while (1) {
10197             if (++$i > $#char) {
10198 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10199 0         0 }
10200             if ($char[$i] eq ']') {
10201             my $right = $i;
10202 0         0  
10203             # [...]
10204 0         0 splice @char, $left, $right-$left+1, Egb18030::charlist_qr(@char[$left+1..$right-1], $modifier);
10205 0         0  
10206             $i = $left;
10207             last;
10208             }
10209             }
10210             }
10211              
10212 0         0 # open character class [^...]
10213 0 0       0 elsif ($char[$i] eq '[^') {
10214 0         0 my $left = $i;
10215             if ($char[$i+1] eq ']') {
10216 0         0 $i++;
10217 0 0       0 }
10218 0         0 while (1) {
10219             if (++$i > $#char) {
10220 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10221 0         0 }
10222             if ($char[$i] eq ']') {
10223             my $right = $i;
10224 0         0  
10225             # [^...]
10226 0         0 splice @char, $left, $right-$left+1, Egb18030::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10227 0         0  
10228             $i = $left;
10229             last;
10230             }
10231             }
10232             }
10233              
10234 0         0 # escape $ @ / and \
10235             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10236             $char[$i] = '\\' . $char[$i];
10237             }
10238              
10239 0         0 # rewrite character class or escape character
10240             elsif (my $char = character_class($char[$i],$modifier)) {
10241             $char[$i] = $char;
10242             }
10243              
10244 6 50       12 # /i modifier
10245 8         19 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egb18030::uc($char[$i]) ne Egb18030::fc($char[$i]))) {
10246             if (CORE::length(Egb18030::fc($char[$i])) == 1) {
10247             $char[$i] = '[' . Egb18030::uc($char[$i]) . Egb18030::fc($char[$i]) . ']';
10248 8         24 }
10249             else {
10250             $char[$i] = '(?:' . Egb18030::uc($char[$i]) . '|' . Egb18030::fc($char[$i]) . ')';
10251             }
10252             }
10253              
10254 0 0       0 # quote character before ? + * {
10255             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10256             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
10257 0         0 }
10258             else {
10259             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10260             }
10261             }
10262 0         0 }
10263 44         98  
10264 44         81 $modifier =~ tr/i//d;
10265 44         67 $delimiter = '/';
10266 44         80 $end_delimiter = '/';
10267 44         105 my $prematch = '';
10268             $prematch = "($anchor)";
10269             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10270             }
10271              
10272             #
10273             # escape regexp (s'here''b)
10274 44     44 0 392 #
10275             sub e_s1_qb {
10276             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10277 44         145  
10278             # split regexp
10279             my @char = $string =~ /\G (?>[^\\]|\\\\|[\x00-\xFF]) /oxmsg;
10280 44         200  
10281 44 50       160 # unescape character
    50          
10282             for (my $i=0; $i <= $#char; $i++) {
10283             if (0) {
10284             }
10285 98         450  
10286             # remain \\
10287             elsif ($char[$i] eq '\\\\') {
10288             }
10289              
10290 0         0 # escape $ @ / and \
10291             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10292             $char[$i] = '\\' . $char[$i];
10293             }
10294 0         0 }
10295 44         108  
10296 44         83 $delimiter = '/';
10297 44         1145 $end_delimiter = '/';
10298 44         73 my $prematch = '';
10299             $prematch = q{(\G[\x00-\xFF]*?)};
10300             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10301             }
10302              
10303             #
10304             # escape regexp (s''here')
10305 44     91 0 490 #
10306             sub e_s2_q {
10307 91         238 my($ope,$delimiter,$end_delimiter,$string) = @_;
10308              
10309 91         144 $slash = 'div';
10310 91         1545  
10311 91 50 66     328 my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\\\|$q_char) /oxmsg;
    50 33        
    100          
    100          
10312             for (my $i=0; $i <= $#char; $i++) {
10313             if (0) {
10314             }
10315 9         89  
10316 0         0 # escape last octet of multiple-octet
10317             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10318             $char[$i] = $1 . '\\' . $2;
10319 0         0 }
10320             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10321             $char[$i] = $1 . '\\' . $2;
10322             }
10323              
10324             # not escape \\
10325             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
10326             }
10327              
10328 0         0 # escape $ @ / and \
10329             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10330             $char[$i] = '\\' . $char[$i];
10331 5 50 66     17 }
10332 91         252 }
10333             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10334             $char[-1] = $1 . '\\' . $2;
10335 0         0 }
10336              
10337             return join '', $ope, $delimiter, @char, $end_delimiter;
10338             }
10339              
10340             #
10341             # escape regexp (s/here/and here/modifier)
10342 91     292 0 297 #
10343 292   100     2510 sub e_sub {
10344             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
10345 292         1375 $modifier ||= '';
10346 292 50       919  
10347 292         1099 $modifier =~ tr/p//d;
10348 0         0 if ($modifier =~ /([adlu])/oxms) {
10349 0 0       0 my $line = 0;
10350 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10351 0         0 if ($filename ne __FILE__) {
10352             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10353             last;
10354 0         0 }
10355             }
10356             die qq{Unsupported modifier "$1" used at line $line.\n};
10357 0 100       0 }
10358 292         981  
10359 37         53 if ($variable eq '') {
10360             $variable = '$_';
10361             $bind_operator = ' =~ ';
10362 37         56 }
10363              
10364             $slash = 'div';
10365              
10366             # P.128 Start of match (or end of previous match): \G
10367             # P.130 Advanced Use of \G with Perl
10368             # in Chapter 3: Overview of Regular Expression Features and Flavors
10369             # P.312 Iterative Matching: Scalar Context, with /g
10370             # in Chapter 7: Perl
10371             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
10372              
10373             # P.181 Where You Left Off: The \G Assertion
10374             # in Chapter 5: Pattern Matching
10375             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10376              
10377             # P.220 Where You Left Off: The \G Assertion
10378             # in Chapter 5: Pattern Matching
10379 292         502 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10380 292         548  
10381             my $e_modifier = $modifier =~ tr/e//d;
10382 292         531 my $r_modifier = $modifier =~ tr/r//d;
10383 292 50       463  
10384 292         810 my $my = '';
10385 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
10386 0         0 $my = $variable;
10387             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
10388             $variable =~ s/ = .+ \z//oxms;
10389 0         0 }
10390 292         831  
10391             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
10392             $variable_basename =~ s/ \s+ \z//oxms;
10393 292         858  
10394 292 100       516 # quote replacement string
10395 292         727 my $e_replacement = '';
10396 17         37 if ($e_modifier >= 1) {
10397             $e_replacement = e_qq('', '', '', $replacement);
10398             $e_modifier--;
10399 17 100       25 }
10400 275         626 else {
10401             if ($delimiter2 eq "'") {
10402             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
10403 91         268 }
10404             else {
10405             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
10406             }
10407 184         457 }
10408              
10409             my $sub = '';
10410 292 100       1738  
10411 292 100       696 # with /r
    50          
10412             if ($r_modifier) {
10413             if (0) {
10414             }
10415 8         33  
10416 0 50       0 # s///gr with 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             '$Egb18030::re_r=CORE::eval $Egb18030::re_r; ' x $e_modifier, # 5
10429             );
10430             }
10431              
10432 4 0       39 # s///gr without multibyte anchoring
10433             elsif ($modifier =~ /g/oxms) {
10434             $sub = sprintf(
10435             # 1 2 3 4 5
10436             q,
10437              
10438             $variable, # 1
10439             ($delimiter1 eq "'") ? # 2
10440             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10441             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10442             $s_matched, # 3
10443             $e_replacement, # 4
10444             '$Egb18030::re_r=CORE::eval $Egb18030::re_r; ' x $e_modifier, # 5
10445             );
10446             }
10447              
10448             # s///r
10449 0         0 else {
10450 4         11  
10451             my $prematch = q{$`};
10452 4 50       6 $prematch = q{${1}};
10453              
10454             $sub = sprintf(
10455             # 1 2 3 4 5 6 7
10456             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Egb18030::re_r=%s; %s"%s$Egb18030::re_r$'" } : %s>,
10457              
10458             $variable, # 1
10459             ($delimiter1 eq "'") ? # 2
10460             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10461             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10462             $s_matched, # 3
10463             $e_replacement, # 4
10464             '$Egb18030::re_r=CORE::eval $Egb18030::re_r; ' x $e_modifier, # 5
10465             $prematch, # 6
10466             $variable, # 7
10467             );
10468             }
10469 4 50       21  
10470 8         28 # $var !~ s///r doesn't make sense
10471             if ($bind_operator =~ / !~ /oxms) {
10472             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
10473             }
10474             }
10475              
10476 0 100       0 # without /r
    50          
10477             else {
10478             if (0) {
10479             }
10480 284         1181  
10481 0 100       0 # s///g with multibyte anchoring
    100          
10482             elsif ($modifier =~ /g/oxms) {
10483             $sub = sprintf(
10484             # 1 2 3 4 5 6 7 8 9 10
10485             q,
10486              
10487             $variable, # 1
10488             ($delimiter1 eq "'") ? # 2
10489             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10490             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10491             $s_matched, # 3
10492             $e_replacement, # 4
10493             '$Egb18030::re_r=CORE::eval $Egb18030::re_r; ' x $e_modifier, # 5
10494             $variable, # 6
10495             $variable, # 7
10496             $variable, # 8
10497             $variable, # 9
10498              
10499             # Binary "!~" is just like "=~" except the return value is negated in the logical sense.
10500             # It returns false if the match succeeds, and true if it fails.
10501             # (and so on)
10502              
10503             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 10
10504             );
10505             }
10506              
10507 35 0       168 # s///g without multibyte anchoring
    0          
10508             elsif ($modifier =~ /g/oxms) {
10509             $sub = sprintf(
10510             # 1 2 3 4 5 6 7 8
10511             q,
10512              
10513             $variable, # 1
10514             ($delimiter1 eq "'") ? # 2
10515             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10516             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10517             $s_matched, # 3
10518             $e_replacement, # 4
10519             '$Egb18030::re_r=CORE::eval $Egb18030::re_r; ' x $e_modifier, # 5
10520             $variable, # 6
10521             $variable, # 7
10522             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
10523             );
10524             }
10525              
10526             # s///
10527 0         0 else {
10528 249         448  
10529             my $prematch = q{$`};
10530 249 100       413 $prematch = q{${1}};
    100          
10531              
10532             $sub = sprintf(
10533              
10534             ($bind_operator =~ / =~ /oxms) ?
10535              
10536             # 1 2 3 4 5 6 7 8
10537             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Egb18030::re_r=%s; %s%s="%s$Egb18030::re_r$'"; 1 } : undef> :
10538              
10539             # 1 2 3 4 5 6 7 8
10540             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Egb18030::re_r=%s; %s%s="%s$Egb18030::re_r$'"; undef }>,
10541              
10542             $variable, # 1
10543             $bind_operator, # 2
10544             ($delimiter1 eq "'") ? # 3
10545             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10546             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10547             $s_matched, # 4
10548             $e_replacement, # 5
10549             '$Egb18030::re_r=CORE::eval $Egb18030::re_r; ' x $e_modifier, # 6
10550             $variable, # 7
10551             $prematch, # 8
10552             );
10553             }
10554             }
10555 249 50       1487  
10556 292         803 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
10557             if ($my ne '') {
10558             $sub = "($my, $sub)[1]";
10559             }
10560 0         0  
10561 292         456 # clear s/// variable
10562             $sub_variable = '';
10563 292         416 $bind_operator = '';
10564              
10565             return $sub;
10566             }
10567              
10568             #
10569             # escape chdir (qq//, "")
10570 292     0 0 2475 #
10571             sub e_chdir {
10572 0 0       0 my($ope,$delimiter,$end_delimiter,$string) = @_;
10573 0 0       0  
10574 0 0       0 if ($^W) {
10575 0         0 if (Egb18030::_MSWin32_5Cended_path($string)) {
10576 0         0 if ($] !~ /^5\.005/oxms) {
10577             warn <
10578             @{[__FILE__]}: Can't chdir to '$string'
10579              
10580             chdir does not work with chr(0x5C) at end of path
10581             http://bugs.activestate.com/show_bug.cgi?id=81839
10582             END
10583             }
10584             }
10585 0         0 }
10586              
10587             return e_qq($ope,$delimiter,$end_delimiter,$string);
10588             }
10589              
10590             #
10591             # escape chdir (q//, '')
10592 0     2 0 0 #
10593             sub e_chdir_q {
10594 2 50       5 my($ope,$delimiter,$end_delimiter,$string) = @_;
10595 2 0       7  
10596 0 0       0 if ($^W) {
10597 0         0 if (Egb18030::_MSWin32_5Cended_path($string)) {
10598 0         0 if ($] !~ /^5\.005/oxms) {
10599             warn <
10600             @{[__FILE__]}: Can't chdir to '$string'
10601              
10602             chdir does not work with chr(0x5C) at end of path
10603             http://bugs.activestate.com/show_bug.cgi?id=81839
10604             END
10605             }
10606             }
10607 0         0 }
10608              
10609             return e_q($ope,$delimiter,$end_delimiter,$string);
10610             }
10611              
10612             #
10613             # escape regexp of split qr//
10614 2     285 0 15 #
10615 285   100     1533 sub e_split {
10616             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10617 285         1236 $modifier ||= '';
10618 285 50       604  
10619 285         761 $modifier =~ tr/p//d;
10620 0         0 if ($modifier =~ /([adlu])/oxms) {
10621 0 0       0 my $line = 0;
10622 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10623 0         0 if ($filename ne __FILE__) {
10624             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10625             last;
10626 0         0 }
10627             }
10628             die qq{Unsupported modifier "$1" used at line $line.\n};
10629 0         0 }
10630              
10631             $slash = 'div';
10632 285 100       504  
10633 285         662 # /b /B modifier
10634             if ($modifier =~ tr/bB//d) {
10635             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10636 84 100       468 }
10637 201         648  
10638             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10639             my $metachar = qr/[\@\\|[\]{^]/oxms;
10640 201         774  
10641             # split regexp
10642             my @char = $string =~ /\G((?>
10643             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
10644             \\x (?>[0-9A-Fa-f]{1,2}) |
10645             \\ (?>[0-7]{2,3}) |
10646             \\c [\x40-\x5F] |
10647             \\x\{ (?>[0-9A-Fa-f]+) \} |
10648             \\o\{ (?>[0-7]+) \} |
10649             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
10650             \\ $q_char |
10651             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
10652             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
10653             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
10654             [\$\@] $qq_variable |
10655             \$ (?>\s* [0-9]+) |
10656             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
10657             \$ \$ (?![\w\{]) |
10658             \$ (?>\s*) \$ (?>\s*) $qq_variable |
10659             \[\^ |
10660             \[\: (?>[a-z]+) :\] |
10661             \[\:\^ (?>[a-z]+) :\] |
10662             \(\? |
10663             $q_char
10664 201         19150 ))/oxmsg;
10665 201         740  
10666 201         325 my $left_e = 0;
10667             my $right_e = 0;
10668             for (my $i=0; $i <= $#char; $i++) {
10669 201 50 33     636  
    50 33        
    100          
    100          
    50          
    50          
10670 384         3165 # "\L\u" --> "\u\L"
10671             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
10672             @char[$i,$i+1] = @char[$i+1,$i];
10673             }
10674              
10675 0         0 # "\U\l" --> "\l\U"
10676             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
10677             @char[$i,$i+1] = @char[$i+1,$i];
10678             }
10679              
10680 0         0 # octal escape sequence
10681             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
10682             $char[$i] = Egb18030::octchr($1);
10683             }
10684              
10685 1         4 # hexadecimal escape sequence
10686             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
10687             $char[$i] = Egb18030::hexchr($1);
10688             }
10689              
10690             # \b{...} --> b\{...}
10691             # \B{...} --> B\{...}
10692             # \N{CHARNAME} --> N\{CHARNAME}
10693             # \p{PROPERTY} --> p\{PROPERTY}
10694 1         3 # \P{PROPERTY} --> P\{PROPERTY}
10695             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
10696             $char[$i] = $1 . '\\' . $2;
10697             }
10698              
10699 0         0 # \p, \P, \X --> p, P, X
10700             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
10701             $char[$i] = $1;
10702 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          
10703              
10704             if (0) {
10705             }
10706 384         4276  
10707 0         0 # escape last octet of multiple-octet
10708             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10709             $char[$i] = $1 . '\\' . $2;
10710             }
10711              
10712 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
10713 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
10714             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)) {
10715             $char[$i] .= join '', splice @char, $i+1, 3;
10716 0         0 }
10717             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)) {
10718             $char[$i] .= join '', splice @char, $i+1, 2;
10719 0         0 }
10720             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)) {
10721             $char[$i] .= join '', splice @char, $i+1, 1;
10722             }
10723             }
10724              
10725 0         0 # open character class [...]
10726 3 50       7 elsif ($char[$i] eq '[') {
10727 3         11 my $left = $i;
10728             if ($char[$i+1] eq ']') {
10729 0         0 $i++;
10730 3 50       6 }
10731 7         14 while (1) {
10732             if (++$i > $#char) {
10733 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10734 7         15 }
10735             if ($char[$i] eq ']') {
10736             my $right = $i;
10737 3 50       7  
10738 3         17 # [...]
  0         0  
10739             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10740             splice @char, $left, $right-$left+1, sprintf(q{@{[Egb18030::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10741 0         0 }
10742             else {
10743             splice @char, $left, $right-$left+1, Egb18030::charlist_qr(@char[$left+1..$right-1], $modifier);
10744 3         18 }
10745 3         7  
10746             $i = $left;
10747             last;
10748             }
10749             }
10750             }
10751              
10752 3         7 # open character class [^...]
10753 1 50       2 elsif ($char[$i] eq '[^') {
10754 1         4 my $left = $i;
10755             if ($char[$i+1] eq ']') {
10756 0         0 $i++;
10757 1 50       2 }
10758 2         5 while (1) {
10759             if (++$i > $#char) {
10760 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10761 2         4 }
10762             if ($char[$i] eq ']') {
10763             my $right = $i;
10764 1 50       3  
10765 1         7 # [^...]
  0         0  
10766             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10767             splice @char, $left, $right-$left+1, sprintf(q{@{[Egb18030::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10768 0         0 }
10769             else {
10770             splice @char, $left, $right-$left+1, Egb18030::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10771 1         18 }
10772 1         2  
10773             $i = $left;
10774             last;
10775             }
10776             }
10777             }
10778              
10779 1         4 # rewrite character class or escape character
10780             elsif (my $char = character_class($char[$i],$modifier)) {
10781             $char[$i] = $char;
10782             }
10783              
10784             # P.794 29.2.161. split
10785             # in Chapter 29: Functions
10786             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10787              
10788             # P.951 split
10789             # in Chapter 27: Functions
10790             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10791              
10792             # said "The //m modifier is assumed when you split on the pattern /^/",
10793             # but perl5.008 is not so. Therefore, this software adds //m.
10794             # (and so on)
10795              
10796 5         18 # split(m/^/) --> split(m/^/m)
10797             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
10798             $modifier .= 'm';
10799             }
10800              
10801 14 50       61 # /i modifier
10802 18         47 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egb18030::uc($char[$i]) ne Egb18030::fc($char[$i]))) {
10803             if (CORE::length(Egb18030::fc($char[$i])) == 1) {
10804             $char[$i] = '[' . Egb18030::uc($char[$i]) . Egb18030::fc($char[$i]) . ']';
10805 18         50 }
10806             else {
10807             $char[$i] = '(?:' . Egb18030::uc($char[$i]) . '|' . Egb18030::fc($char[$i]) . ')';
10808             }
10809             }
10810              
10811 0 50       0 # \u \l \U \L \F \Q \E
10812 2         8 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
10813             if ($right_e < $left_e) {
10814             $char[$i] = '\\' . $char[$i];
10815             }
10816 0         0 }
10817 0         0 elsif ($char[$i] eq '\u') {
10818             $char[$i] = '@{[Egb18030::ucfirst qq<';
10819             $left_e++;
10820 0         0 }
10821 0         0 elsif ($char[$i] eq '\l') {
10822             $char[$i] = '@{[Egb18030::lcfirst qq<';
10823             $left_e++;
10824 0         0 }
10825 0         0 elsif ($char[$i] eq '\U') {
10826             $char[$i] = '@{[Egb18030::uc qq<';
10827             $left_e++;
10828 0         0 }
10829 0         0 elsif ($char[$i] eq '\L') {
10830             $char[$i] = '@{[Egb18030::lc qq<';
10831             $left_e++;
10832 0         0 }
10833 0         0 elsif ($char[$i] eq '\F') {
10834             $char[$i] = '@{[Egb18030::fc qq<';
10835             $left_e++;
10836 0         0 }
10837 0         0 elsif ($char[$i] eq '\Q') {
10838             $char[$i] = '@{[CORE::quotemeta qq<';
10839             $left_e++;
10840 0 0       0 }
10841 0         0 elsif ($char[$i] eq '\E') {
10842 0         0 if ($right_e < $left_e) {
10843             $char[$i] = '>]}';
10844             $right_e++;
10845 0         0 }
10846             else {
10847             $char[$i] = '';
10848             }
10849 0         0 }
10850 0 0       0 elsif ($char[$i] eq '\Q') {
10851 0         0 while (1) {
10852             if (++$i > $#char) {
10853 0 0       0 last;
10854 0         0 }
10855             if ($char[$i] eq '\E') {
10856             last;
10857             }
10858             }
10859             }
10860             elsif ($char[$i] eq '\E') {
10861             }
10862              
10863 0 0       0 # $0 --> $0
10864 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
10865             if ($ignorecase) {
10866             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10867             }
10868 0 0       0 }
10869 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
10870             if ($ignorecase) {
10871             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10872             }
10873             }
10874              
10875             # $$ --> $$
10876             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10877             }
10878              
10879             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10880 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
10881 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10882 0         0 $char[$i] = e_capture($1);
10883             if ($ignorecase) {
10884             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10885             }
10886 0         0 }
10887 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10888 0         0 $char[$i] = e_capture($1);
10889             if ($ignorecase) {
10890             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10891             }
10892             }
10893              
10894 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10895 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) {
10896 0         0 $char[$i] = e_capture($1.'->'.$2);
10897             if ($ignorecase) {
10898             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10899             }
10900             }
10901              
10902 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10903 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) {
10904 0         0 $char[$i] = e_capture($1.'->'.$2);
10905             if ($ignorecase) {
10906             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10907             }
10908             }
10909              
10910 0         0 # $$foo
10911 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10912 0         0 $char[$i] = e_capture($1);
10913             if ($ignorecase) {
10914             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10915             }
10916             }
10917              
10918 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Egb18030::PREMATCH()
10919 12         35 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10920             if ($ignorecase) {
10921             $char[$i] = '@{[Egb18030::ignorecase(Egb18030::PREMATCH())]}';
10922 0         0 }
10923             else {
10924             $char[$i] = '@{[Egb18030::PREMATCH()]}';
10925             }
10926             }
10927              
10928 12 50       69 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Egb18030::MATCH()
10929 12         36 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10930             if ($ignorecase) {
10931             $char[$i] = '@{[Egb18030::ignorecase(Egb18030::MATCH())]}';
10932 0         0 }
10933             else {
10934             $char[$i] = '@{[Egb18030::MATCH()]}';
10935             }
10936             }
10937              
10938 12 50       67 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Egb18030::POSTMATCH()
10939 9         28 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10940             if ($ignorecase) {
10941             $char[$i] = '@{[Egb18030::ignorecase(Egb18030::POSTMATCH())]}';
10942 0         0 }
10943             else {
10944             $char[$i] = '@{[Egb18030::POSTMATCH()]}';
10945             }
10946             }
10947              
10948 9 0       57 # ${ foo }
10949 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) {
10950             if ($ignorecase) {
10951             $char[$i] = '@{[Egb18030::ignorecase(' . $1 . ')]}';
10952             }
10953             }
10954              
10955 0         0 # ${ ... }
10956 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10957 0         0 $char[$i] = e_capture($1);
10958             if ($ignorecase) {
10959             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10960             }
10961             }
10962              
10963 0         0 # $scalar or @array
10964 3 50       12 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10965 3         17 $char[$i] = e_string($char[$i]);
10966             if ($ignorecase) {
10967             $char[$i] = '@{[Egb18030::ignorecase(' . $char[$i] . ')]}';
10968             }
10969             }
10970              
10971 0 100       0 # quote character before ? + * {
10972             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10973             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10974 7         42 }
10975             else {
10976             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10977             }
10978             }
10979             }
10980 4         22  
10981 201 50       545 # make regexp string
10982 201         494 $modifier =~ tr/i//d;
10983             if ($left_e > $right_e) {
10984 0         0 return join '', 'Egb18030::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
10985             }
10986             return join '', 'Egb18030::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
10987             }
10988              
10989             #
10990             # escape regexp of split qr''
10991 201     112 0 1964 #
10992 112   100     522 sub e_split_q {
10993             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10994 112         310 $modifier ||= '';
10995 112 50       199  
10996 112         261 $modifier =~ tr/p//d;
10997 0         0 if ($modifier =~ /([adlu])/oxms) {
10998 0 0       0 my $line = 0;
10999 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
11000 0         0 if ($filename ne __FILE__) {
11001             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
11002             last;
11003 0         0 }
11004             }
11005             die qq{Unsupported modifier "$1" used at line $line.\n};
11006 0         0 }
11007              
11008             $slash = 'div';
11009 112 100       1808  
11010 112         211 # /b /B modifier
11011             if ($modifier =~ tr/bB//d) {
11012             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
11013 56 100       277 }
11014              
11015             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
11016 56         145  
11017             # split regexp
11018             my @char = $string =~ /\G((?>
11019             [^\x81-\xFE\\\[] |
11020             [\x81-\xFE][^\x30-\x39]|[\x81-\xFE][\x30-\x39][\x81-\xFE][\x00-\xFF] |
11021             \[\^ |
11022             \[\: (?>[a-z]+) \:\] |
11023             \[\:\^ (?>[a-z]+) \:\] |
11024             \\ (?:$q_char) |
11025             (?:$q_char)
11026             ))/oxmsg;
11027 56         347  
11028 56 50 33     194 # unescape character
    50 100        
    50 66        
    50 33        
    50          
    100          
    50          
11029             for (my $i=0; $i <= $#char; $i++) {
11030             if (0) {
11031             }
11032 56         496  
11033 0         0 # escape last octet of multiple-octet
11034             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
11035             $char[$i] = $1 . '\\' . $2;
11036             }
11037              
11038 0         0 # open character class [...]
11039 0 0       0 elsif ($char[$i] eq '[') {
11040 0         0 my $left = $i;
11041             if ($char[$i+1] eq ']') {
11042 0         0 $i++;
11043 0 0       0 }
11044 0         0 while (1) {
11045             if (++$i > $#char) {
11046 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11047 0         0 }
11048             if ($char[$i] eq ']') {
11049             my $right = $i;
11050 0         0  
11051             # [...]
11052 0         0 splice @char, $left, $right-$left+1, Egb18030::charlist_qr(@char[$left+1..$right-1], $modifier);
11053 0         0  
11054             $i = $left;
11055             last;
11056             }
11057             }
11058             }
11059              
11060 0         0 # open character class [^...]
11061 0 0       0 elsif ($char[$i] eq '[^') {
11062 0         0 my $left = $i;
11063             if ($char[$i+1] eq ']') {
11064 0         0 $i++;
11065 0 0       0 }
11066 0         0 while (1) {
11067             if (++$i > $#char) {
11068 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11069 0         0 }
11070             if ($char[$i] eq ']') {
11071             my $right = $i;
11072 0         0  
11073             # [^...]
11074 0         0 splice @char, $left, $right-$left+1, Egb18030::charlist_not_qr(@char[$left+1..$right-1], $modifier);
11075 0         0  
11076             $i = $left;
11077             last;
11078             }
11079             }
11080             }
11081              
11082 0         0 # rewrite character class or escape character
11083             elsif (my $char = character_class($char[$i],$modifier)) {
11084             $char[$i] = $char;
11085             }
11086              
11087 0         0 # split(m/^/) --> split(m/^/m)
11088             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
11089             $modifier .= 'm';
11090             }
11091              
11092 0 50       0 # /i modifier
11093 12         33 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Egb18030::uc($char[$i]) ne Egb18030::fc($char[$i]))) {
11094             if (CORE::length(Egb18030::fc($char[$i])) == 1) {
11095             $char[$i] = '[' . Egb18030::uc($char[$i]) . Egb18030::fc($char[$i]) . ']';
11096 12         35 }
11097             else {
11098             $char[$i] = '(?:' . Egb18030::uc($char[$i]) . '|' . Egb18030::fc($char[$i]) . ')';
11099             }
11100             }
11101              
11102 0 0       0 # quote character before ? + * {
11103             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
11104             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
11105 0         0 }
11106             else {
11107             $char[$i-1] = '(?:' . $char[$i-1] . ')';
11108             }
11109             }
11110 0         0 }
11111 56         108  
11112             $modifier =~ tr/i//d;
11113             return join '', 'Egb18030::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
11114             }
11115              
11116             #
11117             # escape use without import
11118 56     0 0 299 #
11119             sub e_use_noimport {
11120 0           my($module) = @_;
11121              
11122 0           my $expr = _pathof($module);
11123 0            
11124             my $fh = gensym();
11125 0 0         for my $realfilename (_realfilename($expr)) {
11126 0            
11127 0           if (Egb18030::_open_r($fh, $realfilename)) {
11128 0 0         local $/ = undef; # slurp mode
11129             my $script = <$fh>;
11130 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11131 0            
11132             if ($script =~ /^ (?>\s*) use (?>\s+) GB18030 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11133 0           return qq;
11134             }
11135             last;
11136             }
11137 0           }
11138              
11139             return qq;
11140             }
11141              
11142             #
11143             # escape no without unimport
11144 0     0 0   #
11145             sub e_no_nounimport {
11146 0           my($module) = @_;
11147              
11148 0           my $expr = _pathof($module);
11149 0            
11150             my $fh = gensym();
11151 0 0         for my $realfilename (_realfilename($expr)) {
11152 0            
11153 0           if (Egb18030::_open_r($fh, $realfilename)) {
11154 0 0         local $/ = undef; # slurp mode
11155             my $script = <$fh>;
11156 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11157 0            
11158             if ($script =~ /^ (?>\s*) use (?>\s+) GB18030 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11159 0           return qq;
11160             }
11161             last;
11162             }
11163 0           }
11164              
11165             return qq;
11166             }
11167              
11168             #
11169             # escape use with import no parameter
11170 0     0 0   #
11171             sub e_use_noparam {
11172 0           my($module) = @_;
11173              
11174 0           my $expr = _pathof($module);
11175 0            
11176             my $fh = gensym();
11177 0 0         for my $realfilename (_realfilename($expr)) {
11178 0            
11179 0           if (Egb18030::_open_r($fh, $realfilename)) {
11180 0 0         local $/ = undef; # slurp mode
11181             my $script = <$fh>;
11182 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11183              
11184             if ($script =~ /^ (?>\s*) use (?>\s+) GB18030 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11185              
11186             # P.326 UNIVERSAL: The Ultimate Ancestor Class
11187             # in Chapter 12: Objects
11188             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
11189              
11190             # P.435 UNIVERSAL: The Ultimate Ancestor Class
11191             # in Chapter 12: Objects
11192             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
11193              
11194 0           # (and so on)
11195              
11196 0           return qq[BEGIN { Egb18030::require '$expr'; $module->import() if $module->can('import'); }];
11197             }
11198             last;
11199             }
11200 0           }
11201              
11202             return qq;
11203             }
11204              
11205             #
11206             # escape no with unimport no parameter
11207 0     0 0   #
11208             sub e_no_noparam {
11209 0           my($module) = @_;
11210              
11211 0           my $expr = _pathof($module);
11212 0            
11213             my $fh = gensym();
11214 0 0         for my $realfilename (_realfilename($expr)) {
11215 0            
11216 0           if (Egb18030::_open_r($fh, $realfilename)) {
11217 0 0         local $/ = undef; # slurp mode
11218             my $script = <$fh>;
11219 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11220 0            
11221             if ($script =~ /^ (?>\s*) use (?>\s+) GB18030 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11222 0           return qq[BEGIN { Egb18030::require '$expr'; $module->unimport() if $module->can('unimport'); }];
11223             }
11224             last;
11225             }
11226 0           }
11227              
11228             return qq;
11229             }
11230              
11231             #
11232             # escape use with import parameters
11233 0     0 0   #
11234             sub e_use {
11235 0           my($module,$list) = @_;
11236              
11237 0           my $expr = _pathof($module);
11238 0            
11239             my $fh = gensym();
11240 0 0         for my $realfilename (_realfilename($expr)) {
11241 0            
11242 0           if (Egb18030::_open_r($fh, $realfilename)) {
11243 0 0         local $/ = undef; # slurp mode
11244             my $script = <$fh>;
11245 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11246 0            
11247             if ($script =~ /^ (?>\s*) use (?>\s+) GB18030 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11248 0           return qq[BEGIN { Egb18030::require '$expr'; $module->import($list) if $module->can('import'); }];
11249             }
11250             last;
11251             }
11252 0           }
11253              
11254             return qq;
11255             }
11256              
11257             #
11258             # escape no with unimport parameters
11259 0     0 0   #
11260             sub e_no {
11261 0           my($module,$list) = @_;
11262              
11263 0           my $expr = _pathof($module);
11264 0            
11265             my $fh = gensym();
11266 0 0         for my $realfilename (_realfilename($expr)) {
11267 0            
11268 0           if (Egb18030::_open_r($fh, $realfilename)) {
11269 0 0         local $/ = undef; # slurp mode
11270             my $script = <$fh>;
11271 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11272 0            
11273             if ($script =~ /^ (?>\s*) use (?>\s+) GB18030 (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11274 0           return qq[BEGIN { Egb18030::require '$expr'; $module->unimport($list) if $module->can('unimport'); }];
11275             }
11276             last;
11277             }
11278 0           }
11279              
11280             return qq;
11281             }
11282              
11283             #
11284             # file path of module
11285 0     0     #
11286             sub _pathof {
11287 0 0         my($expr) = @_;
11288 0            
11289             if ($^O eq 'MacOS') {
11290             $expr =~ s#::#:#g;
11291 0           }
11292             else {
11293 0 0         $expr =~ s#::#/#g;
11294             }
11295 0           $expr .= '.pm' if $expr !~ / \.pm \z/oxmsi;
11296              
11297             return $expr;
11298             }
11299              
11300             #
11301             # real file name of module
11302 0     0     #
11303             sub _realfilename {
11304 0 0         my($expr) = @_;
11305 0            
  0            
11306             if ($^O eq 'MacOS') {
11307             return map {"$_$expr"} @INC;
11308 0           }
  0            
11309             else {
11310             return map {"$_/$expr"} @INC;
11311             }
11312             }
11313              
11314             #
11315             # instead of Carp::carp
11316 0     0 0   #
11317 0           sub carp {
11318             my($package,$filename,$line) = caller(1);
11319             print STDERR "@_ at $filename line $line.\n";
11320             }
11321              
11322             #
11323             # instead of Carp::croak
11324 0     0 0   #
11325 0           sub croak {
11326 0           my($package,$filename,$line) = caller(1);
11327             print STDERR "@_ at $filename line $line.\n";
11328             die "\n";
11329             }
11330              
11331             #
11332             # instead of Carp::cluck
11333 0     0 0   #
11334 0           sub cluck {
11335 0           my $i = 0;
11336 0           my @cluck = ();
11337 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11338             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
11339 0           $i++;
11340 0           }
11341 0           print STDERR CORE::reverse @cluck;
11342             print STDERR "\n";
11343             print STDERR @_;
11344             }
11345              
11346             #
11347             # instead of Carp::confess
11348 0     0 0   #
11349 0           sub confess {
11350 0           my $i = 0;
11351 0           my @confess = ();
11352 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11353             push @confess, "[$i] $filename($line) $package::$subroutine\n";
11354 0           $i++;
11355 0           }
11356 0           print STDERR CORE::reverse @confess;
11357 0           print STDERR "\n";
11358             print STDERR @_;
11359             die "\n";
11360             }
11361              
11362             1;
11363              
11364             __END__