File Coverage

blib/lib/Ebig5hkscs.pm
Criterion Covered Total %
statement 1204 4691 25.6
branch 1360 4560 29.8
condition 162 496 32.6
subroutine 68 190 35.7
pod 8 148 5.4
total 2802 10085 27.7


line stmt bran cond sub pod time code
1             package Ebig5hkscs;
2 389     389   14927 use strict;
  389         2279  
  389         15479  
3             ######################################################################
4             #
5             # Ebig5hkscs - Run-time routines for Big5HKSCS.pm
6             #
7             # http://search.cpan.org/dist/Char-Big5HKSCS/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 389     389   5530 use 5.00503; # Galapagos Consensus 1998 for primetools
  389         2923  
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   3476 use vars qw($VERSION);
  389         3711  
  389         58515  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 389 50   389   8763 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 389         2086 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 389         63367 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   29453 CORE::eval q{
  389     389   4195  
  389     114   5977  
  389         52010  
  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       157280 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 return \do { local *_ };
  0         0  
69             }
70              
71             sub qualify ($$) {
72 0     1152 0 0 my($name) = @_;
73              
74 1152 50       2819 if (ref $name) {
    50          
    50          
    50          
    50          
    50          
    50          
75 1152         4509 return $name;
76             }
77             elsif (Ebig5hkscs::index($name,'::') >= 0) {
78 0         0 return $name;
79             }
80             elsif (Ebig5hkscs::index($name,"'") >= 0) {
81 0         0 return $name;
82             }
83              
84             # special character, "^xyz"
85             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
86              
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
89 0         0 return 'main::' . $name;
90             }
91              
92             # Global names
93             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
94 0         0 return 'main::' . $name;
95             }
96              
97             # or other
98             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             elsif (defined $_[1]) {
103 0         0 return $_[1] . '::' . $name;
104             }
105             else {
106 1152         9071 return (caller)[0] . '::' . $name;
107             }
108             }
109              
110             sub qualify_to_ref ($;$) {
111 0 50   1152 0 0 if (defined $_[1]) {
112 389     389   4554 no strict qw(refs);
  389         4579  
  389         32031  
113 1152         4530 return \*{ qualify $_[0], $_[1] };
  0         0  
114             }
115             else {
116 389     389   2351 no strict qw(refs);
  389     0   2402  
  389         107072  
117 0         0 return \*{ qualify $_[0], (caller)[0] };
  1152         1909  
118             }
119             }
120             }
121              
122             # P.714 29.2.39. flock
123             # in Chapter 29: Functions
124             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
125              
126             # P.863 flock
127             # in Chapter 27: Functions
128             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
129              
130             sub LOCK_SH() {1}
131             sub LOCK_EX() {2}
132             sub LOCK_UN() {8}
133             sub LOCK_NB() {4}
134              
135             # instead of Carp.pm
136             sub carp;
137             sub croak;
138             sub cluck;
139             sub confess;
140              
141             # 6.18. Matching Multiple-Byte Characters
142             # in Chapter 6. Pattern Matching
143             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
144             # (and so on)
145              
146             # regexp of character
147             my $your_char = q{[\x81-\xFE][\x00-\xFF]|[\x00-\xFF]};
148 389     389   4259 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  389         2538  
  389         28668  
149 389     389   2621 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  389         923  
  389         654127  
150              
151             #
152             # Big5-HKSCS character range per length
153             #
154             my %range_tr = ();
155              
156             #
157             # Big5-HKSCS case conversion
158             #
159             my %lc = ();
160             @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)} =
161             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);
162             my %uc = ();
163             @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)} =
164             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);
165             my %fc = ();
166             @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)} =
167             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);
168              
169             if (0) {
170             }
171              
172             elsif (__PACKAGE__ =~ / \b Ebig5hkscs \z/oxms) {
173             %range_tr = (
174             1 => [ [0x00..0x80],
175             [0xFF..0xFF],
176             ],
177             2 => [ [0x81..0xFE],[0x40..0x7E],
178             [0x81..0xFE],[0xA1..0xFE],
179             ],
180             );
181             }
182              
183             else {
184             croak "Don't know my package name '@{[__PACKAGE__]}'";
185             }
186              
187             #
188             # @ARGV wildcard globbing
189             #
190             sub import {
191              
192 1152 50   5   7524 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
193 5         86 my @argv = ();
194 0         0 for (@ARGV) {
195              
196             # has space
197 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
198 0 0       0 if (my @glob = Ebig5hkscs::glob(qq{"$_"})) {
199 0         0 push @argv, @glob;
200             }
201             else {
202 0         0 push @argv, $_;
203             }
204             }
205              
206             # has wildcard metachar
207             elsif (/\A (?:$q_char)*? [*?] /oxms) {
208 0 0       0 if (my @glob = Ebig5hkscs::glob($_)) {
209 0         0 push @argv, @glob;
210             }
211             else {
212 0         0 push @argv, $_;
213             }
214             }
215              
216             # no wildcard globbing
217             else {
218 0         0 push @argv, $_;
219             }
220             }
221 0         0 @ARGV = @argv;
222             }
223              
224 0         0 *Char::ord = \&Big5HKSCS::ord;
225 5         28 *Char::ord_ = \&Big5HKSCS::ord_;
226 5         14 *Char::reverse = \&Big5HKSCS::reverse;
227 5         12 *Char::getc = \&Big5HKSCS::getc;
228 5         11 *Char::length = \&Big5HKSCS::length;
229 5         9 *Char::substr = \&Big5HKSCS::substr;
230 5         11 *Char::index = \&Big5HKSCS::index;
231 5         11 *Char::rindex = \&Big5HKSCS::rindex;
232 5         11 *Char::eval = \&Big5HKSCS::eval;
233 5         35 *Char::escape = \&Big5HKSCS::escape;
234 5         12 *Char::escape_token = \&Big5HKSCS::escape_token;
235 5         11 *Char::escape_script = \&Big5HKSCS::escape_script;
236             }
237              
238             # P.230 Care with Prototypes
239             # in Chapter 6: Subroutines
240             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
241             #
242             # If you aren't careful, you can get yourself into trouble with prototypes.
243             # But if you are careful, you can do a lot of neat things with them. This is
244             # all very powerful, of course, and should only be used in moderation to make
245             # the world a better place.
246              
247             # P.332 Care with Prototypes
248             # in Chapter 7: Subroutines
249             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
250             #
251             # If you aren't careful, you can get yourself into trouble with prototypes.
252             # But if you are careful, you can do a lot of neat things with them. This is
253             # all very powerful, of course, and should only be used in moderation to make
254             # the world a better place.
255              
256             #
257             # Prototypes of subroutines
258             #
259       0     sub unimport {}
260             sub Ebig5hkscs::split(;$$$);
261             sub Ebig5hkscs::tr($$$$;$);
262             sub Ebig5hkscs::chop(@);
263             sub Ebig5hkscs::index($$;$);
264             sub Ebig5hkscs::rindex($$;$);
265             sub Ebig5hkscs::lcfirst(@);
266             sub Ebig5hkscs::lcfirst_();
267             sub Ebig5hkscs::lc(@);
268             sub Ebig5hkscs::lc_();
269             sub Ebig5hkscs::ucfirst(@);
270             sub Ebig5hkscs::ucfirst_();
271             sub Ebig5hkscs::uc(@);
272             sub Ebig5hkscs::uc_();
273             sub Ebig5hkscs::fc(@);
274             sub Ebig5hkscs::fc_();
275             sub Ebig5hkscs::ignorecase;
276             sub Ebig5hkscs::classic_character_class;
277             sub Ebig5hkscs::capture;
278             sub Ebig5hkscs::chr(;$);
279             sub Ebig5hkscs::chr_();
280             sub Ebig5hkscs::filetest;
281             sub Ebig5hkscs::r(;*@);
282             sub Ebig5hkscs::w(;*@);
283             sub Ebig5hkscs::x(;*@);
284             sub Ebig5hkscs::o(;*@);
285             sub Ebig5hkscs::R(;*@);
286             sub Ebig5hkscs::W(;*@);
287             sub Ebig5hkscs::X(;*@);
288             sub Ebig5hkscs::O(;*@);
289             sub Ebig5hkscs::e(;*@);
290             sub Ebig5hkscs::z(;*@);
291             sub Ebig5hkscs::s(;*@);
292             sub Ebig5hkscs::f(;*@);
293             sub Ebig5hkscs::d(;*@);
294             sub Ebig5hkscs::l(;*@);
295             sub Ebig5hkscs::p(;*@);
296             sub Ebig5hkscs::S(;*@);
297             sub Ebig5hkscs::b(;*@);
298             sub Ebig5hkscs::c(;*@);
299             sub Ebig5hkscs::u(;*@);
300             sub Ebig5hkscs::g(;*@);
301             sub Ebig5hkscs::k(;*@);
302             sub Ebig5hkscs::T(;*@);
303             sub Ebig5hkscs::B(;*@);
304             sub Ebig5hkscs::M(;*@);
305             sub Ebig5hkscs::A(;*@);
306             sub Ebig5hkscs::C(;*@);
307             sub Ebig5hkscs::filetest_;
308             sub Ebig5hkscs::r_();
309             sub Ebig5hkscs::w_();
310             sub Ebig5hkscs::x_();
311             sub Ebig5hkscs::o_();
312             sub Ebig5hkscs::R_();
313             sub Ebig5hkscs::W_();
314             sub Ebig5hkscs::X_();
315             sub Ebig5hkscs::O_();
316             sub Ebig5hkscs::e_();
317             sub Ebig5hkscs::z_();
318             sub Ebig5hkscs::s_();
319             sub Ebig5hkscs::f_();
320             sub Ebig5hkscs::d_();
321             sub Ebig5hkscs::l_();
322             sub Ebig5hkscs::p_();
323             sub Ebig5hkscs::S_();
324             sub Ebig5hkscs::b_();
325             sub Ebig5hkscs::c_();
326             sub Ebig5hkscs::u_();
327             sub Ebig5hkscs::g_();
328             sub Ebig5hkscs::k_();
329             sub Ebig5hkscs::T_();
330             sub Ebig5hkscs::B_();
331             sub Ebig5hkscs::M_();
332             sub Ebig5hkscs::A_();
333             sub Ebig5hkscs::C_();
334             sub Ebig5hkscs::glob($);
335             sub Ebig5hkscs::glob_();
336             sub Ebig5hkscs::lstat(*);
337             sub Ebig5hkscs::lstat_();
338             sub Ebig5hkscs::opendir(*$);
339             sub Ebig5hkscs::stat(*);
340             sub Ebig5hkscs::stat_();
341             sub Ebig5hkscs::unlink(@);
342             sub Ebig5hkscs::chdir(;$);
343             sub Ebig5hkscs::do($);
344             sub Ebig5hkscs::require(;$);
345             sub Ebig5hkscs::telldir(*);
346              
347             sub Big5HKSCS::ord(;$);
348             sub Big5HKSCS::ord_();
349             sub Big5HKSCS::reverse(@);
350             sub Big5HKSCS::getc(;*@);
351             sub Big5HKSCS::length(;$);
352             sub Big5HKSCS::substr($$;$$);
353             sub Big5HKSCS::index($$;$);
354             sub Big5HKSCS::rindex($$;$);
355             sub Big5HKSCS::escape(;$);
356              
357             #
358             # Regexp work
359             #
360 389         43042 use vars qw(
361             $re_a
362             $re_t
363             $re_n
364             $re_r
365 389     389   6378 );
  389         2094  
366              
367             #
368             # Character class
369             #
370 389         156205 use vars qw(
371             $dot
372             $dot_s
373             $eD
374             $eS
375             $eW
376             $eH
377             $eV
378             $eR
379             $eN
380             $not_alnum
381             $not_alpha
382             $not_ascii
383             $not_blank
384             $not_cntrl
385             $not_digit
386             $not_graph
387             $not_lower
388             $not_lower_i
389             $not_print
390             $not_punct
391             $not_space
392             $not_upper
393             $not_upper_i
394             $not_word
395             $not_xdigit
396             $eb
397             $eB
398 389     389   5482 );
  389         6872  
399              
400 389         4721921 use vars qw(
401             $anchor
402             $matched
403 389     389   6353 );
  389         689  
404             ${Ebig5hkscs::anchor} = qr{\G(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?}oxms;
405             my $q_char_SADAHIRO_Tomoyuki_2002_01_17 = '';
406              
407             # Quantifiers
408             # {n,m} --- Match at least n but not more than m times
409             #
410             # n and m are limited to non-negative integral values less than a
411             # preset limit defined when perl is built. This is usually 32766 on
412             # the most common platforms.
413             #
414             # The following code is an attempt to solve the above limitations
415             # in a multi-byte anchoring.
416              
417             # avoid "Segmentation fault" and "Error: Parse exception"
418              
419             # perl5101delta
420             # http://perldoc.perl.org/perl5101delta.html
421             # In 5.10.0, the * quantifier in patterns was sometimes treated as {0,32767}
422             # [RT #60034, #60464]. For example, this match would fail:
423             # ("ab" x 32768) =~ /^(ab)*$/
424              
425             # SEE ALSO
426             #
427             # Complex regular subexpression recursion limit
428             # http://www.perlmonks.org/?node_id=810857
429             #
430             # regexp iteration limits
431             # http://www.nntp.perl.org/group/perl.perl5.porters/2009/02/msg144065.html
432             #
433             # latest Perl won't match certain regexes more than 32768 characters long
434             # http://stackoverflow.com/questions/26226630/latest-perl-wont-match-certain-regexes-more-than-32768-characters-long
435             #
436             # Break through the limitations of regular expressions of Perl
437             # http://d.hatena.ne.jp/gfx/20110212/1297512479
438              
439             if (($] >= 5.010001) or
440             # ActivePerl 5.6 or later (include 5.10.0)
441             (defined($ActivePerl::VERSION) and ($ActivePerl::VERSION > 800)) or
442             (($^O eq 'MSWin32') and ($] =~ /\A 5\.006/oxms))
443             ) {
444             my $sbcs = ''; # Single Byte Character Set
445             for my $range (@{ $range_tr{1} }) {
446             $sbcs .= sprintf('\\x%02X-\\x%02X', $range->[0], $range->[-1]);
447             }
448              
449             if (0) {
450             }
451              
452             # other encoding
453             else {
454             ${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[$sbcs](?:[^$sbcs][^$sbcs])*?}oxms;
455             # ******* octets not in multiple octet char (always char boundary)
456             # **************** 2 octet chars
457             }
458              
459             ${Ebig5hkscs::anchor_SADAHIRO_Tomoyuki_2002_01_17} =
460             qr{\G(?(?=.{0,32766}\z)(?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?|(?(?=[$sbcs]+\z).*?|(?:${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17})))}oxms;
461             # qr{
462             # \G # (1), (2)
463             # (? # (3)
464             # (?=.{0,32766}\z) # (4)
465             # (?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?| # (5)
466             # (?(?=[$sbcs]+\z) # (6)
467             # .*?| #(7)
468             # (?:${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17}) # (8)
469             # ))}oxms;
470              
471             # avoid: Complex regular subexpression recursion limit (32766) exceeded at here.
472             local $^W = 0;
473              
474             if (((('A' x 32768).'B') !~ / ${Ebig5hkscs::anchor} B /oxms) and
475             ((('A' x 32768).'B') =~ / ${Ebig5hkscs::anchor_SADAHIRO_Tomoyuki_2002_01_17} B /oxms)
476             ) {
477             ${Ebig5hkscs::anchor} = ${Ebig5hkscs::anchor_SADAHIRO_Tomoyuki_2002_01_17};
478             }
479             else {
480             undef ${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17};
481             }
482             }
483              
484             # (1)
485             # P.128 Start of match (or end of previous match): \G
486             # P.130 Advanced Use of \G with Perl
487             # in Chapter3: Over view of Regular Expression Features and Flavors
488             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
489              
490             # (2)
491             # P.255 Use leading anchors
492             # P.256 Expose ^ and \G at the front of expressions
493             # in Chapter6: Crafting an Efficient Expression
494             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
495              
496             # (3)
497             # P.138 Conditional: (? if then| else)
498             # in Chapter3: Over view of Regular Expression Features and Flavors
499             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
500              
501             # (4)
502             # perlre
503             # http://perldoc.perl.org/perlre.html
504             # The "*" quantifier is equivalent to {0,} , the "+" quantifier to {1,} ,
505             # and the "?" quantifier to {0,1}, ., n, and m are limited to non-negative
506             # integral values less than a preset limit defined when perl is built.
507             # This is usually 32766 on the most common platforms. The actual limit
508             # can be seen in the error message generated by code such as this:
509             # $_ **= $_ , / {$_} / for 2 .. 42;
510              
511             # (5)
512             # P.1023 Multiple-Byte Anchoring
513             # in Appendix W Perl Code Examples
514             # of ISBN 1-56592-224-7 CJKV Information Processing
515              
516             # (6)
517             # if string has only SBCS (Single Byte Character Set)
518              
519             # (7)
520             # then .*? (isn't limited to 32766)
521              
522             # (8)
523             # else Big5-HKSCS::Regexp::Const (SADAHIRO Tomoyuki)
524             # http://homepage1.nifty.com/nomenclator/perl/shiftjis.htm#long
525             # http://search.cpan.org/~sadahiro/Big5-HKSCS-Regexp/
526             # $PadA = ' (?:\A| [\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
527             # $PadG = '\G(?: |[\x00-\xFF]*?[\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
528             # $PadGA = '\G(?:\A|(?:[\x81-\xFE]{2})+?|[\x00-\xFF]*?[\x00-\x80\xA0-\xDF] (?:[\x81-\xFE]{2})*?)';
529              
530             ${Ebig5hkscs::dot} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
531             ${Ebig5hkscs::dot_s} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])};
532             ${Ebig5hkscs::eD} = qr{(?>[^\x81-\xFE0-9]|[\x81-\xFE][\x00-\xFF])};
533              
534             # Vertical tabs are now whitespace
535             # \s in a regex now matches a vertical tab in all circumstances.
536             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
537             # ${Ebig5hkscs::eS} = qr{(?>[^\x81-\xFE\x09\x0A \x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
538             # ${Ebig5hkscs::eS} = qr{(?>[^\x81-\xFE\x09\x0A\x0B\x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
539             ${Ebig5hkscs::eS} = qr{(?>[^\x81-\xFE\s]|[\x81-\xFE][\x00-\xFF])};
540              
541             ${Ebig5hkscs::eW} = qr{(?>[^\x81-\xFE0-9A-Z_a-z]|[\x81-\xFE][\x00-\xFF])};
542             ${Ebig5hkscs::eH} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
543             ${Ebig5hkscs::eV} = qr{(?>[^\x81-\xFE\x0A\x0B\x0C\x0D]|[\x81-\xFE][\x00-\xFF])};
544             ${Ebig5hkscs::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
545             ${Ebig5hkscs::eN} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
546             ${Ebig5hkscs::not_alnum} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
547             ${Ebig5hkscs::not_alpha} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
548             ${Ebig5hkscs::not_ascii} = qr{(?>[^\x81-\xFE\x00-\x7F]|[\x81-\xFE][\x00-\xFF])};
549             ${Ebig5hkscs::not_blank} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
550             ${Ebig5hkscs::not_cntrl} = qr{(?>[^\x81-\xFE\x00-\x1F\x7F]|[\x81-\xFE][\x00-\xFF])};
551             ${Ebig5hkscs::not_digit} = qr{(?>[^\x81-\xFE\x30-\x39]|[\x81-\xFE][\x00-\xFF])};
552             ${Ebig5hkscs::not_graph} = qr{(?>[^\x81-\xFE\x21-\x7F]|[\x81-\xFE][\x00-\xFF])};
553             ${Ebig5hkscs::not_lower} = qr{(?>[^\x81-\xFE\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
554             ${Ebig5hkscs::not_lower_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
555             # ${Ebig5hkscs::not_lower_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
556             ${Ebig5hkscs::not_print} = qr{(?>[^\x81-\xFE\x20-\x7F]|[\x81-\xFE][\x00-\xFF])};
557             ${Ebig5hkscs::not_punct} = qr{(?>[^\x81-\xFE\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]|[\x81-\xFE][\x00-\xFF])};
558             ${Ebig5hkscs::not_space} = qr{(?>[^\x81-\xFE\s\x0B]|[\x81-\xFE][\x00-\xFF])};
559             ${Ebig5hkscs::not_upper} = qr{(?>[^\x81-\xFE\x41-\x5A]|[\x81-\xFE][\x00-\xFF])};
560             ${Ebig5hkscs::not_upper_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
561             # ${Ebig5hkscs::not_upper_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
562             ${Ebig5hkscs::not_word} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x5F\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
563             ${Ebig5hkscs::not_xdigit} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x46\x61-\x66]|[\x81-\xFE][\x00-\xFF])};
564             ${Ebig5hkscs::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))};
565             ${Ebig5hkscs::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]))};
566              
567             # avoid: Name "Ebig5hkscs::foo" used only once: possible typo at here.
568             ${Ebig5hkscs::dot} = ${Ebig5hkscs::dot};
569             ${Ebig5hkscs::dot_s} = ${Ebig5hkscs::dot_s};
570             ${Ebig5hkscs::eD} = ${Ebig5hkscs::eD};
571             ${Ebig5hkscs::eS} = ${Ebig5hkscs::eS};
572             ${Ebig5hkscs::eW} = ${Ebig5hkscs::eW};
573             ${Ebig5hkscs::eH} = ${Ebig5hkscs::eH};
574             ${Ebig5hkscs::eV} = ${Ebig5hkscs::eV};
575             ${Ebig5hkscs::eR} = ${Ebig5hkscs::eR};
576             ${Ebig5hkscs::eN} = ${Ebig5hkscs::eN};
577             ${Ebig5hkscs::not_alnum} = ${Ebig5hkscs::not_alnum};
578             ${Ebig5hkscs::not_alpha} = ${Ebig5hkscs::not_alpha};
579             ${Ebig5hkscs::not_ascii} = ${Ebig5hkscs::not_ascii};
580             ${Ebig5hkscs::not_blank} = ${Ebig5hkscs::not_blank};
581             ${Ebig5hkscs::not_cntrl} = ${Ebig5hkscs::not_cntrl};
582             ${Ebig5hkscs::not_digit} = ${Ebig5hkscs::not_digit};
583             ${Ebig5hkscs::not_graph} = ${Ebig5hkscs::not_graph};
584             ${Ebig5hkscs::not_lower} = ${Ebig5hkscs::not_lower};
585             ${Ebig5hkscs::not_lower_i} = ${Ebig5hkscs::not_lower_i};
586             ${Ebig5hkscs::not_print} = ${Ebig5hkscs::not_print};
587             ${Ebig5hkscs::not_punct} = ${Ebig5hkscs::not_punct};
588             ${Ebig5hkscs::not_space} = ${Ebig5hkscs::not_space};
589             ${Ebig5hkscs::not_upper} = ${Ebig5hkscs::not_upper};
590             ${Ebig5hkscs::not_upper_i} = ${Ebig5hkscs::not_upper_i};
591             ${Ebig5hkscs::not_word} = ${Ebig5hkscs::not_word};
592             ${Ebig5hkscs::not_xdigit} = ${Ebig5hkscs::not_xdigit};
593             ${Ebig5hkscs::eb} = ${Ebig5hkscs::eb};
594             ${Ebig5hkscs::eB} = ${Ebig5hkscs::eB};
595              
596             #
597             # Big5-HKSCS split
598             #
599             sub Ebig5hkscs::split(;$$$) {
600              
601             # P.794 29.2.161. split
602             # in Chapter 29: Functions
603             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
604              
605             # P.951 split
606             # in Chapter 27: Functions
607             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
608              
609 5     0 0 11506 my $pattern = $_[0];
610 0         0 my $string = $_[1];
611 0         0 my $limit = $_[2];
612              
613             # if $pattern is also omitted or is the literal space, " "
614 0 0       0 if (not defined $pattern) {
615 0         0 $pattern = ' ';
616             }
617              
618             # if $string is omitted, the function splits the $_ string
619 0 0       0 if (not defined $string) {
620 0 0       0 if (defined $_) {
621 0         0 $string = $_;
622             }
623             else {
624 0         0 $string = '';
625             }
626             }
627              
628 0         0 my @split = ();
629              
630             # when string is empty
631 0 0       0 if ($string eq '') {
    0          
632              
633             # resulting list value in list context
634 0 0       0 if (wantarray) {
635 0         0 return @split;
636             }
637              
638             # count of substrings in scalar context
639             else {
640 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
641 0         0 @_ = @split;
642 0         0 return scalar @_;
643             }
644             }
645              
646             # split's first argument is more consistently interpreted
647             #
648             # After some changes earlier in v5.17, split's behavior has been simplified:
649             # if the PATTERN argument evaluates to a string containing one space, it is
650             # treated the way that a literal string containing one space once was.
651             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
652              
653             # if $pattern is also omitted or is the literal space, " ", the function splits
654             # on whitespace, /\s+/, after skipping any leading whitespace
655             # (and so on)
656              
657             elsif ($pattern eq ' ') {
658 0 0       0 if (not defined $limit) {
659 0         0 return CORE::split(' ', $string);
660             }
661             else {
662 0         0 return CORE::split(' ', $string, $limit);
663             }
664             }
665              
666 0         0 local $q_char = $q_char;
667 0 0       0 if (CORE::length($string) > 32766) {
668 0 0       0 if ($string =~ /\A [\x00-\x7F]+ \z/oxms) {
    0          
669 0         0 $q_char = qr{.}s;
670             }
671             elsif (defined ${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17}) {
672 0         0 $q_char = ${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17};
673             }
674             }
675              
676             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
677 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
678              
679             # a pattern capable of matching either the null string or something longer than the
680             # null string will split the value of $string into separate characters wherever it
681             # matches the null string between characters
682             # (and so on)
683              
684 0 0       0 if ('' =~ / \A $pattern \z /xms) {
685 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
686 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
687              
688             # P.1024 Appendix W.10 Multibyte Processing
689             # of ISBN 1-56592-224-7 CJKV Information Processing
690             # (and so on)
691              
692             # the //m modifier is assumed when you split on the pattern /^/
693             # (and so on)
694              
695             # V
696 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
697              
698             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
699             # is included in the resulting list, interspersed with the fields that are ordinarily returned
700             # (and so on)
701              
702 0         0 local $@;
703 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
704 0         0 push @split, CORE::eval('$' . $digit);
705             }
706             }
707             }
708              
709             else {
710 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
711              
712             # V
713 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
714 0         0 local $@;
715 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
716 0         0 push @split, CORE::eval('$' . $digit);
717             }
718             }
719             }
720             }
721              
722             elsif ($limit > 0) {
723 0 0       0 if ('' =~ / \A $pattern \z /xms) {
724 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
725 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
726              
727             # V
728 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
729 0         0 local $@;
730 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
731 0         0 push @split, CORE::eval('$' . $digit);
732             }
733             }
734             }
735             }
736             else {
737 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
738 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
739              
740             # V
741 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
742 0         0 local $@;
743 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
744 0         0 push @split, CORE::eval('$' . $digit);
745             }
746             }
747             }
748             }
749             }
750              
751 0 0       0 if (CORE::length($string) > 0) {
752 0         0 push @split, $string;
753             }
754              
755             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
756 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
757 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
758 0         0 pop @split;
759             }
760             }
761              
762             # resulting list value in list context
763 0 0       0 if (wantarray) {
764 0         0 return @split;
765             }
766              
767             # count of substrings in scalar context
768             else {
769 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
770 0         0 @_ = @split;
771 0         0 return scalar @_;
772             }
773             }
774              
775             #
776             # get last subexpression offsets
777             #
778             sub _last_subexpression_offsets {
779 0     0   0 my $pattern = $_[0];
780              
781             # remove comment
782 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
783              
784 0         0 my $modifier = '';
785 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
786 0         0 $modifier = $1;
787 0         0 $modifier =~ s/-[A-Za-z]*//;
788             }
789              
790             # with /x modifier
791 0         0 my @char = ();
792 0 0       0 if ($modifier =~ /x/oxms) {
793 0         0 @char = $pattern =~ /\G((?>
794             [^\x81-\xFE\\\#\[\(]|[\x81-\xFE][\x00-\xFF] |
795             \\ $q_char |
796             \# (?>[^\n]*) $ |
797             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
798             \(\? |
799             $q_char
800             ))/oxmsg;
801             }
802              
803             # without /x modifier
804             else {
805 0         0 @char = $pattern =~ /\G((?>
806             [^\x81-\xFE\\\[\(]|[\x81-\xFE][\x00-\xFF] |
807             \\ $q_char |
808             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
809             \(\? |
810             $q_char
811             ))/oxmsg;
812             }
813              
814 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
815             }
816              
817             #
818             # Big5-HKSCS transliteration (tr///)
819             #
820             sub Ebig5hkscs::tr($$$$;$) {
821              
822 0     0 0 0 my $bind_operator = $_[1];
823 0         0 my $searchlist = $_[2];
824 0         0 my $replacementlist = $_[3];
825 0   0     0 my $modifier = $_[4] || '';
826              
827 0 0       0 if ($modifier =~ /r/oxms) {
828 0 0       0 if ($bind_operator =~ / !~ /oxms) {
829 0         0 croak "Using !~ with tr///r doesn't make sense";
830             }
831             }
832              
833 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
834 0         0 my @searchlist = _charlist_tr($searchlist);
835 0         0 my @replacementlist = _charlist_tr($replacementlist);
836              
837 0         0 my %tr = ();
838 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
839 0 0       0 if (not exists $tr{$searchlist[$i]}) {
840 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
841 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
842             }
843             elsif ($modifier =~ /d/oxms) {
844 0         0 $tr{$searchlist[$i]} = '';
845             }
846             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
847 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
848             }
849             else {
850 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
851             }
852             }
853             }
854              
855 0         0 my $tr = 0;
856 0         0 my $replaced = '';
857 0 0       0 if ($modifier =~ /c/oxms) {
858 0         0 while (defined(my $char = shift @char)) {
859 0 0       0 if (not exists $tr{$char}) {
860 0 0       0 if (defined $replacementlist[0]) {
861 0         0 $replaced .= $replacementlist[0];
862             }
863 0         0 $tr++;
864 0 0       0 if ($modifier =~ /s/oxms) {
865 0   0     0 while (@char and (not exists $tr{$char[0]})) {
866 0         0 shift @char;
867 0         0 $tr++;
868             }
869             }
870             }
871             else {
872 0         0 $replaced .= $char;
873             }
874             }
875             }
876             else {
877 0         0 while (defined(my $char = shift @char)) {
878 0 0       0 if (exists $tr{$char}) {
879 0         0 $replaced .= $tr{$char};
880 0         0 $tr++;
881 0 0       0 if ($modifier =~ /s/oxms) {
882 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
883 0         0 shift @char;
884 0         0 $tr++;
885             }
886             }
887             }
888             else {
889 0         0 $replaced .= $char;
890             }
891             }
892             }
893              
894 0 0       0 if ($modifier =~ /r/oxms) {
895 0         0 return $replaced;
896             }
897             else {
898 0         0 $_[0] = $replaced;
899 0 0       0 if ($bind_operator =~ / !~ /oxms) {
900 0         0 return not $tr;
901             }
902             else {
903 0         0 return $tr;
904             }
905             }
906             }
907              
908             #
909             # Big5-HKSCS chop
910             #
911             sub Ebig5hkscs::chop(@) {
912              
913 0     0 0 0 my $chop;
914 0 0       0 if (@_ == 0) {
915 0         0 my @char = /\G (?>$q_char) /oxmsg;
916 0         0 $chop = pop @char;
917 0         0 $_ = join '', @char;
918             }
919             else {
920 0         0 for (@_) {
921 0         0 my @char = /\G (?>$q_char) /oxmsg;
922 0         0 $chop = pop @char;
923 0         0 $_ = join '', @char;
924             }
925             }
926 0         0 return $chop;
927             }
928              
929             #
930             # Big5-HKSCS index by octet
931             #
932             sub Ebig5hkscs::index($$;$) {
933              
934 0     2304 1 0 my($str,$substr,$position) = @_;
935 2304   50     4801 $position ||= 0;
936 2304         9330 my $pos = 0;
937              
938 2304         2848 while ($pos < CORE::length($str)) {
939 2304 50       5162 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
940 64284 0       123614 if ($pos >= $position) {
941 0         0 return $pos;
942             }
943             }
944 0 50       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
945 64284         151743 $pos += CORE::length($1);
946             }
947             else {
948 64284         111581 $pos += 1;
949             }
950             }
951 0         0 return -1;
952             }
953              
954             #
955             # Big5-HKSCS reverse index
956             #
957             sub Ebig5hkscs::rindex($$;$) {
958              
959 2304     0 0 13707 my($str,$substr,$position) = @_;
960 0   0     0 $position ||= CORE::length($str) - 1;
961 0         0 my $pos = 0;
962 0         0 my $rindex = -1;
963              
964 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
965 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
966 0         0 $rindex = $pos;
967             }
968 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
969 0         0 $pos += CORE::length($1);
970             }
971             else {
972 0         0 $pos += 1;
973             }
974             }
975 0         0 return $rindex;
976             }
977              
978             #
979             # Big5-HKSCS lower case first with parameter
980             #
981             sub Ebig5hkscs::lcfirst(@) {
982 0 0   0 0 0 if (@_) {
983 0         0 my $s = shift @_;
984 0 0 0     0 if (@_ and wantarray) {
985 0         0 return Ebig5hkscs::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
986             }
987             else {
988 0         0 return Ebig5hkscs::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
989             }
990             }
991             else {
992 0         0 return Ebig5hkscs::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
993             }
994             }
995              
996             #
997             # Big5-HKSCS lower case first without parameter
998             #
999             sub Ebig5hkscs::lcfirst_() {
1000 0     0 0 0 return Ebig5hkscs::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1001             }
1002              
1003             #
1004             # Big5-HKSCS lower case with parameter
1005             #
1006             sub Ebig5hkscs::lc(@) {
1007 0 0   0 0 0 if (@_) {
1008 0         0 my $s = shift @_;
1009 0 0 0     0 if (@_ and wantarray) {
1010 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1011             }
1012             else {
1013 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1014             }
1015             }
1016             else {
1017 0         0 return Ebig5hkscs::lc_();
1018             }
1019             }
1020              
1021             #
1022             # Big5-HKSCS lower case without parameter
1023             #
1024             sub Ebig5hkscs::lc_() {
1025 0     0 0 0 my $s = $_;
1026 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1027             }
1028              
1029             #
1030             # Big5-HKSCS upper case first with parameter
1031             #
1032             sub Ebig5hkscs::ucfirst(@) {
1033 0 0   0 0 0 if (@_) {
1034 0         0 my $s = shift @_;
1035 0 0 0     0 if (@_ and wantarray) {
1036 0         0 return Ebig5hkscs::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1037             }
1038             else {
1039 0         0 return Ebig5hkscs::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1040             }
1041             }
1042             else {
1043 0         0 return Ebig5hkscs::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1044             }
1045             }
1046              
1047             #
1048             # Big5-HKSCS upper case first without parameter
1049             #
1050             sub Ebig5hkscs::ucfirst_() {
1051 0     0 0 0 return Ebig5hkscs::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1052             }
1053              
1054             #
1055             # Big5-HKSCS upper case with parameter
1056             #
1057             sub Ebig5hkscs::uc(@) {
1058 0 50   2968 0 0 if (@_) {
1059 2968         4309 my $s = shift @_;
1060 2968 50 33     3623 if (@_ and wantarray) {
1061 2968 0       5422 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1062             }
1063             else {
1064 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  2968         7902  
1065             }
1066             }
1067             else {
1068 2968         10129 return Ebig5hkscs::uc_();
1069             }
1070             }
1071              
1072             #
1073             # Big5-HKSCS upper case without parameter
1074             #
1075             sub Ebig5hkscs::uc_() {
1076 0     0 0 0 my $s = $_;
1077 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1078             }
1079              
1080             #
1081             # Big5-HKSCS fold case with parameter
1082             #
1083             sub Ebig5hkscs::fc(@) {
1084 0 50   3271 0 0 if (@_) {
1085 3271         4480 my $s = shift @_;
1086 3271 50 33     3705 if (@_ and wantarray) {
1087 3271 0       5425 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1088             }
1089             else {
1090 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3271         7989  
1091             }
1092             }
1093             else {
1094 3271         12006 return Ebig5hkscs::fc_();
1095             }
1096             }
1097              
1098             #
1099             # Big5-HKSCS fold case without parameter
1100             #
1101             sub Ebig5hkscs::fc_() {
1102 0     0 0 0 my $s = $_;
1103 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1104             }
1105              
1106             #
1107             # Big5-HKSCS regexp capture
1108             #
1109             {
1110             # 10.3. Creating Persistent Private Variables
1111             # in Chapter 10. Subroutines
1112             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
1113              
1114             my $last_s_matched = 0;
1115              
1116             sub Ebig5hkscs::capture {
1117 0 0 0 0 1 0 if ($last_s_matched and ($_[0] =~ /\A (?>[1-9][0-9]*) \z/oxms)) {
1118 0         0 return $_[0] + 1;
1119             }
1120 0         0 return $_[0];
1121             }
1122              
1123             # Big5-HKSCS mark last regexp matched
1124             sub Ebig5hkscs::matched() {
1125 0     0 0 0 $last_s_matched = 0;
1126             }
1127              
1128             # Big5-HKSCS mark last s/// matched
1129             sub Ebig5hkscs::s_matched() {
1130 0     0 0 0 $last_s_matched = 1;
1131             }
1132              
1133             # P.854 31.17. use re
1134             # in Chapter 31. Pragmatic Modules
1135             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1136              
1137             # P.1026 re
1138             # in Chapter 29. Pragmatic Modules
1139             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1140              
1141             $Ebig5hkscs::matched = qr/(?{Ebig5hkscs::matched})/;
1142             }
1143              
1144             #
1145             # Big5-HKSCS regexp ignore case modifier
1146             #
1147             sub Ebig5hkscs::ignorecase {
1148              
1149 0     0 0 0 my @string = @_;
1150 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1151              
1152             # ignore case of $scalar or @array
1153 0         0 for my $string (@string) {
1154              
1155             # split regexp
1156 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1157              
1158             # unescape character
1159 0         0 for (my $i=0; $i <= $#char; $i++) {
1160 0 0       0 next if not defined $char[$i];
1161              
1162             # open character class [...]
1163 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1164 0         0 my $left = $i;
1165              
1166             # [] make die "unmatched [] in regexp ...\n"
1167              
1168 0 0       0 if ($char[$i+1] eq ']') {
1169 0         0 $i++;
1170             }
1171              
1172 0         0 while (1) {
1173 0 0       0 if (++$i > $#char) {
1174 0         0 croak "Unmatched [] in regexp";
1175             }
1176 0 0       0 if ($char[$i] eq ']') {
1177 0         0 my $right = $i;
1178 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1179              
1180             # escape character
1181 0         0 for my $char (@charlist) {
1182 0 0       0 if (0) {
    0          
1183             }
1184              
1185             # do not use quotemeta here
1186 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1187 0         0 $char = $1 . '\\' . $2;
1188             }
1189             elsif ($char =~ /\A [.|)] \z/oxms) {
1190 0         0 $char = '\\' . $char;
1191             }
1192             }
1193              
1194             # [...]
1195 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1196              
1197 0         0 $i = $left;
1198 0         0 last;
1199             }
1200             }
1201             }
1202              
1203             # open character class [^...]
1204             elsif ($char[$i] eq '[^') {
1205 0         0 my $left = $i;
1206              
1207             # [^] make die "unmatched [] in regexp ...\n"
1208              
1209 0 0       0 if ($char[$i+1] eq ']') {
1210 0         0 $i++;
1211             }
1212              
1213 0         0 while (1) {
1214 0 0       0 if (++$i > $#char) {
1215 0         0 croak "Unmatched [] in regexp";
1216             }
1217 0 0       0 if ($char[$i] eq ']') {
1218 0         0 my $right = $i;
1219 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1220              
1221             # escape character
1222 0         0 for my $char (@charlist) {
1223 0 0       0 if (0) {
    0          
1224             }
1225              
1226             # do not use quotemeta here
1227 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1228 0         0 $char = $1 . '\\' . $2;
1229             }
1230             elsif ($char =~ /\A [.|)] \z/oxms) {
1231 0         0 $char = '\\' . $char;
1232             }
1233             }
1234              
1235             # [^...]
1236 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1237              
1238 0         0 $i = $left;
1239 0         0 last;
1240             }
1241             }
1242             }
1243              
1244             # rewrite classic character class or escape character
1245             elsif (my $char = classic_character_class($char[$i])) {
1246 0         0 $char[$i] = $char;
1247             }
1248              
1249             # with /i modifier
1250             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1251 0         0 my $uc = Ebig5hkscs::uc($char[$i]);
1252 0         0 my $fc = Ebig5hkscs::fc($char[$i]);
1253 0 0       0 if ($uc ne $fc) {
1254 0 0       0 if (CORE::length($fc) == 1) {
1255 0         0 $char[$i] = '[' . $uc . $fc . ']';
1256             }
1257             else {
1258 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1259             }
1260             }
1261             }
1262             }
1263              
1264             # characterize
1265 0         0 for (my $i=0; $i <= $#char; $i++) {
1266 0 0       0 next if not defined $char[$i];
1267              
1268 0 0 0     0 if (0) {
    0          
1269             }
1270              
1271             # escape last octet of multiple-octet
1272 0         0 elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1273 0         0 $char[$i] = $1 . '\\' . $2;
1274             }
1275              
1276             # quote character before ? + * {
1277             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1278 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1279 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1280             }
1281             }
1282             }
1283              
1284 0         0 $string = join '', @char;
1285             }
1286              
1287             # make regexp string
1288 0         0 return @string;
1289             }
1290              
1291             #
1292             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1293             #
1294             sub Ebig5hkscs::classic_character_class {
1295 0     5319 0 0 my($char) = @_;
1296              
1297             return {
1298             '\D' => '${Ebig5hkscs::eD}',
1299             '\S' => '${Ebig5hkscs::eS}',
1300             '\W' => '${Ebig5hkscs::eW}',
1301             '\d' => '[0-9]',
1302              
1303             # Before Perl 5.6, \s only matched the five whitespace characters
1304             # tab, newline, form-feed, carriage return, and the space character
1305             # itself, which, taken together, is the character class [\t\n\f\r ].
1306              
1307             # Vertical tabs are now whitespace
1308             # \s in a regex now matches a vertical tab in all circumstances.
1309             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1310             # \t \n \v \f \r space
1311             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1312             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1313             '\s' => '\s',
1314              
1315             '\w' => '[0-9A-Z_a-z]',
1316             '\C' => '[\x00-\xFF]',
1317             '\X' => 'X',
1318              
1319             # \h \v \H \V
1320              
1321             # P.114 Character Class Shortcuts
1322             # in Chapter 7: In the World of Regular Expressions
1323             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1324              
1325             # P.357 13.2.3 Whitespace
1326             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1327             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1328             #
1329             # 0x00009 CHARACTER TABULATION h s
1330             # 0x0000a LINE FEED (LF) vs
1331             # 0x0000b LINE TABULATION v
1332             # 0x0000c FORM FEED (FF) vs
1333             # 0x0000d CARRIAGE RETURN (CR) vs
1334             # 0x00020 SPACE h s
1335              
1336             # P.196 Table 5-9. Alphanumeric regex metasymbols
1337             # in Chapter 5. Pattern Matching
1338             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1339              
1340             # (and so on)
1341              
1342             '\H' => '${Ebig5hkscs::eH}',
1343             '\V' => '${Ebig5hkscs::eV}',
1344             '\h' => '[\x09\x20]',
1345             '\v' => '[\x0A\x0B\x0C\x0D]',
1346             '\R' => '${Ebig5hkscs::eR}',
1347              
1348             # \N
1349             #
1350             # http://perldoc.perl.org/perlre.html
1351             # Character Classes and other Special Escapes
1352             # Any character but \n (experimental). Not affected by /s modifier
1353              
1354             '\N' => '${Ebig5hkscs::eN}',
1355              
1356             # \b \B
1357              
1358             # P.180 Boundaries: The \b and \B Assertions
1359             # in Chapter 5: Pattern Matching
1360             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1361              
1362             # P.219 Boundaries: The \b and \B Assertions
1363             # in Chapter 5: Pattern Matching
1364             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1365              
1366             # \b really means (?:(?<=\w)(?!\w)|(?
1367             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1368             '\b' => '${Ebig5hkscs::eb}',
1369              
1370             # \B really means (?:(?<=\w)(?=\w)|(?
1371             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1372             '\B' => '${Ebig5hkscs::eB}',
1373              
1374 5319   100     7637 }->{$char} || '';
1375             }
1376              
1377             #
1378             # prepare Big5-HKSCS characters per length
1379             #
1380              
1381             # 1 octet characters
1382             my @chars1 = ();
1383             sub chars1 {
1384 5319 0   0 0 171771 if (@chars1) {
1385 0         0 return @chars1;
1386             }
1387 0 0       0 if (exists $range_tr{1}) {
1388 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1389 0         0 while (my @range = splice(@ranges,0,1)) {
1390 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1391 0         0 push @chars1, pack 'C', $oct0;
1392             }
1393             }
1394             }
1395 0         0 return @chars1;
1396             }
1397              
1398             # 2 octets characters
1399             my @chars2 = ();
1400             sub chars2 {
1401 0 0   0 0 0 if (@chars2) {
1402 0         0 return @chars2;
1403             }
1404 0 0       0 if (exists $range_tr{2}) {
1405 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1406 0         0 while (my @range = splice(@ranges,0,2)) {
1407 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1408 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1409 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1410             }
1411             }
1412             }
1413             }
1414 0         0 return @chars2;
1415             }
1416              
1417             # 3 octets characters
1418             my @chars3 = ();
1419             sub chars3 {
1420 0 0   0 0 0 if (@chars3) {
1421 0         0 return @chars3;
1422             }
1423 0 0       0 if (exists $range_tr{3}) {
1424 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1425 0         0 while (my @range = splice(@ranges,0,3)) {
1426 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1427 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1428 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1429 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1430             }
1431             }
1432             }
1433             }
1434             }
1435 0         0 return @chars3;
1436             }
1437              
1438             # 4 octets characters
1439             my @chars4 = ();
1440             sub chars4 {
1441 0 0   0 0 0 if (@chars4) {
1442 0         0 return @chars4;
1443             }
1444 0 0       0 if (exists $range_tr{4}) {
1445 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1446 0         0 while (my @range = splice(@ranges,0,4)) {
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 for my $oct3 (@{$range[3]}) {
  0         0  
1451 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1452             }
1453             }
1454             }
1455             }
1456             }
1457             }
1458 0         0 return @chars4;
1459             }
1460              
1461             #
1462             # Big5-HKSCS open character list for tr
1463             #
1464             sub _charlist_tr {
1465              
1466 0     0   0 local $_ = shift @_;
1467              
1468             # unescape character
1469 0         0 my @char = ();
1470 0         0 while (not /\G \z/oxmsgc) {
1471 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1472 0         0 push @char, '\-';
1473             }
1474             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1475 0         0 push @char, CORE::chr(oct $1);
1476             }
1477             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1478 0         0 push @char, CORE::chr(hex $1);
1479             }
1480             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1481 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1482             }
1483             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1484             push @char, {
1485             '\0' => "\0",
1486             '\n' => "\n",
1487             '\r' => "\r",
1488             '\t' => "\t",
1489             '\f' => "\f",
1490             '\b' => "\x08", # \b means backspace in character class
1491             '\a' => "\a",
1492             '\e' => "\e",
1493 0         0 }->{$1};
1494             }
1495             elsif (/\G \\ ($q_char) /oxmsgc) {
1496 0         0 push @char, $1;
1497             }
1498             elsif (/\G ($q_char) /oxmsgc) {
1499 0         0 push @char, $1;
1500             }
1501             }
1502              
1503             # join separated multiple-octet
1504 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1505              
1506             # unescape '-'
1507 0         0 my @i = ();
1508 0         0 for my $i (0 .. $#char) {
1509 0 0       0 if ($char[$i] eq '\-') {
    0          
1510 0         0 $char[$i] = '-';
1511             }
1512             elsif ($char[$i] eq '-') {
1513 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1514 0         0 push @i, $i;
1515             }
1516             }
1517             }
1518              
1519             # open character list (reverse for splice)
1520 0         0 for my $i (CORE::reverse @i) {
1521 0         0 my @range = ();
1522              
1523             # range error
1524 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1525 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1526             }
1527              
1528             # range of multiple-octet code
1529 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1530 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1531 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1532             }
1533             elsif (CORE::length($char[$i+1]) == 2) {
1534 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1535 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1536             }
1537             elsif (CORE::length($char[$i+1]) == 3) {
1538 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1539 0         0 push @range, chars2();
1540 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1541             }
1542             elsif (CORE::length($char[$i+1]) == 4) {
1543 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1544 0         0 push @range, chars2();
1545 0         0 push @range, chars3();
1546 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1547             }
1548             else {
1549 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1550             }
1551             }
1552             elsif (CORE::length($char[$i-1]) == 2) {
1553 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1554 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1555             }
1556             elsif (CORE::length($char[$i+1]) == 3) {
1557 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1558 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1559             }
1560             elsif (CORE::length($char[$i+1]) == 4) {
1561 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1562 0         0 push @range, chars3();
1563 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1564             }
1565             else {
1566 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1567             }
1568             }
1569             elsif (CORE::length($char[$i-1]) == 3) {
1570 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1571 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1572             }
1573             elsif (CORE::length($char[$i+1]) == 4) {
1574 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1575 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1576             }
1577             else {
1578 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1579             }
1580             }
1581             elsif (CORE::length($char[$i-1]) == 4) {
1582 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1583 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1584             }
1585             else {
1586 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1587             }
1588             }
1589             else {
1590 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1591             }
1592              
1593 0         0 splice @char, $i-1, 3, @range;
1594             }
1595              
1596 0         0 return @char;
1597             }
1598              
1599             #
1600             # Big5-HKSCS open character class
1601             #
1602             sub _cc {
1603 0 50   604   0 if (scalar(@_) == 0) {
    100          
    50          
1604 604         1248 die __FILE__, ": subroutine cc got no parameter.\n";
1605             }
1606             elsif (scalar(@_) == 1) {
1607 0         0 return sprintf('\x%02X',$_[0]);
1608             }
1609             elsif (scalar(@_) == 2) {
1610 302 50       922 if ($_[0] > $_[1]) {
    50          
    50          
1611 302         694 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1612             }
1613             elsif ($_[0] == $_[1]) {
1614 0         0 return sprintf('\x%02X',$_[0]);
1615             }
1616             elsif (($_[0]+1) == $_[1]) {
1617 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1618             }
1619             else {
1620 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1621             }
1622             }
1623             else {
1624 302         1424 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1625             }
1626             }
1627              
1628             #
1629             # Big5-HKSCS octet range
1630             #
1631             sub _octets {
1632 0     668   0 my $length = shift @_;
1633              
1634 668 100       1092 if ($length == 1) {
    50          
    0          
    0          
1635 668         1404 my($a1) = unpack 'C', $_[0];
1636 406         1044 my($z1) = unpack 'C', $_[1];
1637              
1638 406 50       757 if ($a1 > $z1) {
1639 406         769 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1640             }
1641              
1642 0 100       0 if ($a1 == $z1) {
    50          
1643 406         1114 return sprintf('\x%02X',$a1);
1644             }
1645             elsif (($a1+1) == $z1) {
1646 20         81 return sprintf('\x%02X\x%02X',$a1,$z1);
1647             }
1648             else {
1649 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1650             }
1651             }
1652             elsif ($length == 2) {
1653 386         2396 my($a1,$a2) = unpack 'CC', $_[0];
1654 262         570 my($z1,$z2) = unpack 'CC', $_[1];
1655 262         478 my($A1,$A2) = unpack 'CC', $_[2];
1656 262         424 my($Z1,$Z2) = unpack 'CC', $_[3];
1657              
1658 262 100       384 if ($a1 == $z1) {
    50          
1659             return (
1660             # 11111111 222222222222
1661             # A A Z
1662 262         410 _cc($a1) . _cc($a2,$z2), # a2-z2
1663             );
1664             }
1665             elsif (($a1+1) == $z1) {
1666             return (
1667             # 11111111111 222222222222
1668             # A Z A Z
1669 222         353 _cc($a1) . _cc($a2,$Z2), # a2-
1670             _cc( $z1) . _cc($A2,$z2), # -z2
1671             );
1672             }
1673             else {
1674             return (
1675             # 1111111111111111 222222222222
1676             # A Z A Z
1677 40         63 _cc($a1) . _cc($a2,$Z2), # a2-
1678             _cc($a1+1,$z1-1) . _cc($A2,$Z2), # -
1679             _cc( $z1) . _cc($A2,$z2), # -z2
1680             );
1681             }
1682             }
1683             elsif ($length == 3) {
1684 0         0 my($a1,$a2,$a3) = unpack 'CCC', $_[0];
1685 0         0 my($z1,$z2,$z3) = unpack 'CCC', $_[1];
1686 0         0 my($A1,$A2,$A3) = unpack 'CCC', $_[2];
1687 0         0 my($Z1,$Z2,$Z3) = unpack 'CCC', $_[3];
1688              
1689 0 0       0 if ($a1 == $z1) {
    0          
1690 0 0       0 if ($a2 == $z2) {
    0          
1691             return (
1692             # 11111111 22222222 333333333333
1693             # A A A Z
1694 0         0 _cc($a1) . _cc($a2) . _cc($a3,$z3), # a3-z3
1695             );
1696             }
1697             elsif (($a2+1) == $z2) {
1698             return (
1699             # 11111111 22222222222 333333333333
1700             # A A Z A Z
1701 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1702             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1703             );
1704             }
1705             else {
1706             return (
1707             # 11111111 2222222222222222 333333333333
1708             # A A Z A Z
1709 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1710             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3), # -
1711             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1712             );
1713             }
1714             }
1715             elsif (($a1+1) == $z1) {
1716             return (
1717             # 11111111111 22222222222222 333333333333
1718             # A Z A Z A Z
1719 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1720             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1721             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1722             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1723             );
1724             }
1725             else {
1726             return (
1727             # 1111111111111111 22222222222222 333333333333
1728             # A Z A Z A Z
1729 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1730             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1731             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3), # -
1732             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1733             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1734             );
1735             }
1736             }
1737             elsif ($length == 4) {
1738 0         0 my($a1,$a2,$a3,$a4) = unpack 'CCCC', $_[0];
1739 0         0 my($z1,$z2,$z3,$z4) = unpack 'CCCC', $_[1];
1740 0         0 my($A1,$A2,$A3,$A4) = unpack 'CCCC', $_[0];
1741 0         0 my($Z1,$Z2,$Z3,$Z4) = unpack 'CCCC', $_[1];
1742              
1743 0 0       0 if ($a1 == $z1) {
    0          
1744 0 0       0 if ($a2 == $z2) {
    0          
1745 0 0       0 if ($a3 == $z3) {
    0          
1746             return (
1747             # 11111111 22222222 33333333 444444444444
1748             # A A A A Z
1749 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$z4), # a4-z4
1750             );
1751             }
1752             elsif (($a3+1) == $z3) {
1753             return (
1754             # 11111111 22222222 33333333333 444444444444
1755             # A A A Z A Z
1756 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1757             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1758             );
1759             }
1760             else {
1761             return (
1762             # 11111111 22222222 3333333333333333 444444444444
1763             # A A A Z A Z
1764 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1765             _cc($a1) . _cc($a2) . _cc($a3+1,$z3-1) . _cc($A4,$Z4), # -
1766             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1767             );
1768             }
1769             }
1770             elsif (($a2+1) == $z2) {
1771             return (
1772             # 11111111 22222222222 33333333333333 444444444444
1773             # A A Z A Z A Z
1774 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1775             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1776             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1777             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1778             );
1779             }
1780             else {
1781             return (
1782             # 11111111 2222222222222222 33333333333333 444444444444
1783             # A A Z A Z A Z
1784 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1785             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1786             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1787             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1788             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1789             );
1790             }
1791             }
1792             elsif (($a1+1) == $z1) {
1793             return (
1794             # 11111111111 22222222222222 33333333333333 444444444444
1795             # A Z A Z A Z A Z
1796 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1797             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1798             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1799             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1800             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1801             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1802             );
1803             }
1804             else {
1805             return (
1806             # 1111111111111111 22222222222222 33333333333333 444444444444
1807             # A Z A Z A Z A Z
1808 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1809             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1810             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1811             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1812             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1813             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1814             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1815             );
1816             }
1817             }
1818             else {
1819 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1820             }
1821             }
1822              
1823             #
1824             # Big5-HKSCS range regexp
1825             #
1826             sub _range_regexp {
1827 0     517   0 my($length,$first,$last) = @_;
1828              
1829 517         1094 my @range_regexp = ();
1830 517 50       765 if (not exists $range_tr{$length}) {
1831 517         1582 return @range_regexp;
1832             }
1833              
1834 0         0 my @ranges = @{ $range_tr{$length} };
  517         723  
1835 517         1300 while (my @range = splice(@ranges,0,$length)) {
1836 517         1543 my $min = '';
1837 1034         1437 my $max = '';
1838 1034         1218 for (my $i=0; $i < $length; $i++) {
1839 1034         2028 $min .= pack 'C', $range[$i][0];
1840 1296         2999 $max .= pack 'C', $range[$i][-1];
1841             }
1842              
1843             # min___max
1844             # FIRST_____________LAST
1845             # (nothing)
1846              
1847 1296 50 66     2523 if ($max lt $first) {
    100 100        
    50 33        
    100 100        
    100 66        
    100 66        
    50 66        
1848             }
1849              
1850             # **********
1851             # min_________max
1852             # FIRST_____________LAST
1853             # **********
1854              
1855             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1856 1034         9427 push @range_regexp, _octets($length,$first,$max,$min,$max);
1857             }
1858              
1859             # **********************
1860             # min________________max
1861             # FIRST_____________LAST
1862             # **********************
1863              
1864             elsif (($min eq $first) and ($max eq $last)) {
1865 20         55 push @range_regexp, _octets($length,$first,$last,$min,$max);
1866             }
1867              
1868             # *********
1869             # min___max
1870             # FIRST_____________LAST
1871             # *********
1872              
1873             elsif (($first le $min) and ($max le $last)) {
1874 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1875             }
1876              
1877             # **********************
1878             # min__________________________max
1879             # FIRST_____________LAST
1880             # **********************
1881              
1882             elsif (($min le $first) and ($last le $max)) {
1883 20         36 push @range_regexp, _octets($length,$first,$last,$min,$max);
1884             }
1885              
1886             # *********
1887             # min________max
1888             # FIRST_____________LAST
1889             # *********
1890              
1891             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1892 588         1581 push @range_regexp, _octets($length,$min,$last,$min,$max);
1893             }
1894              
1895             # min___max
1896             # FIRST_____________LAST
1897             # (nothing)
1898              
1899             elsif ($last lt $min) {
1900             }
1901              
1902             else {
1903 40         68 die __FILE__, ": subroutine _range_regexp panic.\n";
1904             }
1905             }
1906              
1907 0         0 return @range_regexp;
1908             }
1909              
1910             #
1911             # Big5-HKSCS open character list for qr and not qr
1912             #
1913             sub _charlist {
1914              
1915 517     758   1256 my $modifier = pop @_;
1916 758         1224 my @char = @_;
1917              
1918 758 100       1657 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1919              
1920             # unescape character
1921 758         1875 for (my $i=0; $i <= $#char; $i++) {
1922              
1923             # escape - to ...
1924 758 100 100     2314 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1925 2648 100 100     18692 if ((0 < $i) and ($i < $#char)) {
1926 522         1880 $char[$i] = '...';
1927             }
1928             }
1929              
1930             # octal escape sequence
1931             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1932 497         1025 $char[$i] = octchr($1);
1933             }
1934              
1935             # hexadecimal escape sequence
1936             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1937 0         0 $char[$i] = hexchr($1);
1938             }
1939              
1940             # \b{...} --> b\{...}
1941             # \B{...} --> B\{...}
1942             # \N{CHARNAME} --> N\{CHARNAME}
1943             # \p{PROPERTY} --> p\{PROPERTY}
1944             # \P{PROPERTY} --> P\{PROPERTY}
1945             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
1946 0         0 $char[$i] = $1 . '\\' . $2;
1947             }
1948              
1949             # \p, \P, \X --> p, P, X
1950             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1951 0         0 $char[$i] = $1;
1952             }
1953              
1954             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1955 0         0 $char[$i] = CORE::chr oct $1;
1956             }
1957             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1958 0         0 $char[$i] = CORE::chr hex $1;
1959             }
1960             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1961 206         733 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1962             }
1963             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1964             $char[$i] = {
1965             '\0' => "\0",
1966             '\n' => "\n",
1967             '\r' => "\r",
1968             '\t' => "\t",
1969             '\f' => "\f",
1970             '\b' => "\x08", # \b means backspace in character class
1971             '\a' => "\a",
1972             '\e' => "\e",
1973             '\d' => '[0-9]',
1974              
1975             # Vertical tabs are now whitespace
1976             # \s in a regex now matches a vertical tab in all circumstances.
1977             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1978             # \t \n \v \f \r space
1979             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1980             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1981             '\s' => '\s',
1982              
1983             '\w' => '[0-9A-Z_a-z]',
1984             '\D' => '${Ebig5hkscs::eD}',
1985             '\S' => '${Ebig5hkscs::eS}',
1986             '\W' => '${Ebig5hkscs::eW}',
1987              
1988             '\H' => '${Ebig5hkscs::eH}',
1989             '\V' => '${Ebig5hkscs::eV}',
1990             '\h' => '[\x09\x20]',
1991             '\v' => '[\x0A\x0B\x0C\x0D]',
1992             '\R' => '${Ebig5hkscs::eR}',
1993              
1994 0         0 }->{$1};
1995             }
1996              
1997             # POSIX-style character classes
1998             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1999             $char[$i] = {
2000              
2001             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
2002             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
2003             '[:^lower:]' => '${Ebig5hkscs::not_lower_i}',
2004             '[:^upper:]' => '${Ebig5hkscs::not_upper_i}',
2005              
2006 33         488 }->{$1};
2007             }
2008             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
2009             $char[$i] = {
2010              
2011             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
2012             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
2013             '[:ascii:]' => '[\x00-\x7F]',
2014             '[:blank:]' => '[\x09\x20]',
2015             '[:cntrl:]' => '[\x00-\x1F\x7F]',
2016             '[:digit:]' => '[\x30-\x39]',
2017             '[:graph:]' => '[\x21-\x7F]',
2018             '[:lower:]' => '[\x61-\x7A]',
2019             '[:print:]' => '[\x20-\x7F]',
2020             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
2021              
2022             # P.174 POSIX-Style Character Classes
2023             # in Chapter 5: Pattern Matching
2024             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2025              
2026             # P.311 11.2.4 Character Classes and other Special Escapes
2027             # in Chapter 11: perlre: Perl regular expressions
2028             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2029              
2030             # P.210 POSIX-Style Character Classes
2031             # in Chapter 5: Pattern Matching
2032             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2033              
2034             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
2035              
2036             '[:upper:]' => '[\x41-\x5A]',
2037             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
2038             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
2039             '[:^alnum:]' => '${Ebig5hkscs::not_alnum}',
2040             '[:^alpha:]' => '${Ebig5hkscs::not_alpha}',
2041             '[:^ascii:]' => '${Ebig5hkscs::not_ascii}',
2042             '[:^blank:]' => '${Ebig5hkscs::not_blank}',
2043             '[:^cntrl:]' => '${Ebig5hkscs::not_cntrl}',
2044             '[:^digit:]' => '${Ebig5hkscs::not_digit}',
2045             '[:^graph:]' => '${Ebig5hkscs::not_graph}',
2046             '[:^lower:]' => '${Ebig5hkscs::not_lower}',
2047             '[:^print:]' => '${Ebig5hkscs::not_print}',
2048             '[:^punct:]' => '${Ebig5hkscs::not_punct}',
2049             '[:^space:]' => '${Ebig5hkscs::not_space}',
2050             '[:^upper:]' => '${Ebig5hkscs::not_upper}',
2051             '[:^word:]' => '${Ebig5hkscs::not_word}',
2052             '[:^xdigit:]' => '${Ebig5hkscs::not_xdigit}',
2053              
2054 8         151 }->{$1};
2055             }
2056             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
2057 70         1402 $char[$i] = $1;
2058             }
2059             }
2060              
2061             # open character list
2062 7         35 my @singleoctet = ();
2063 758         1434 my @multipleoctet = ();
2064 758         1359 for (my $i=0; $i <= $#char; ) {
2065              
2066             # escaped -
2067 758 100 100     1607 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
2068 2151         8742 $i += 1;
2069 497         795 next;
2070             }
2071              
2072             # make range regexp
2073             elsif ($char[$i] eq '...') {
2074              
2075             # range error
2076 497 50       2203 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    100          
2077 497         1961 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2078             }
2079             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
2080 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
2081 477         1231 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2082             }
2083             }
2084              
2085             # make range regexp per length
2086 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
2087 497         1316 my @regexp = ();
2088              
2089             # is first and last
2090 517 100 100     766 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    100 33        
    50          
    50          
2091 517         1851 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
2092             }
2093              
2094             # is first
2095             elsif ($length == CORE::length($char[$i-1])) {
2096 477         1419 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
2097             }
2098              
2099             # is inside in first and last
2100             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
2101 20         65 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
2102             }
2103              
2104             # is last
2105             elsif ($length == CORE::length($char[$i+1])) {
2106 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
2107             }
2108              
2109             else {
2110 20         87 die __FILE__, ": subroutine make_regexp panic.\n";
2111             }
2112              
2113 0 100       0 if ($length == 1) {
2114 517         1026 push @singleoctet, @regexp;
2115             }
2116             else {
2117 386         1039 push @multipleoctet, @regexp;
2118             }
2119             }
2120              
2121 131         296 $i += 2;
2122             }
2123              
2124             # with /i modifier
2125             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
2126 497 100       1028 if ($modifier =~ /i/oxms) {
2127 764         1423 my $uc = Ebig5hkscs::uc($char[$i]);
2128 192         303 my $fc = Ebig5hkscs::fc($char[$i]);
2129 192 50       321 if ($uc ne $fc) {
2130 192 50       310 if (CORE::length($fc) == 1) {
2131 192         251 push @singleoctet, $uc, $fc;
2132             }
2133             else {
2134 192         362 push @singleoctet, $uc;
2135 0         0 push @multipleoctet, $fc;
2136             }
2137             }
2138             else {
2139 0         0 push @singleoctet, $char[$i];
2140             }
2141             }
2142             else {
2143 0         0 push @singleoctet, $char[$i];
2144             }
2145 572         1161 $i += 1;
2146             }
2147              
2148             # single character of single octet code
2149             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
2150 764         1569 push @singleoctet, "\t", "\x20";
2151 0         0 $i += 1;
2152             }
2153             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
2154 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
2155 0         0 $i += 1;
2156             }
2157             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
2158 0         0 push @singleoctet, $char[$i];
2159 2         5 $i += 1;
2160             }
2161              
2162             # single character of multiple-octet code
2163             else {
2164 2         6 push @multipleoctet, $char[$i];
2165 391         691 $i += 1;
2166             }
2167             }
2168              
2169             # quote metachar
2170 391         701 for (@singleoctet) {
2171 758 50       1989 if ($_ eq '...') {
    100          
    100          
    100          
    100          
2172 1364         6214 $_ = '-';
2173             }
2174             elsif (/\A \n \z/oxms) {
2175 0         0 $_ = '\n';
2176             }
2177             elsif (/\A \r \z/oxms) {
2178 8         16 $_ = '\r';
2179             }
2180             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
2181 8         24 $_ = sprintf('\x%02X', CORE::ord $1);
2182             }
2183             elsif (/\A [\x00-\xFF] \z/oxms) {
2184 1         5 $_ = quotemeta $_;
2185             }
2186             }
2187 939         1542 for (@multipleoctet) {
2188 758 100       1308 if (/\A ([\x80-\xFF].*) ([\x00-\xFF]) \z/oxms) {
2189 693         1745 $_ = $1 . quotemeta $2;
2190             }
2191             }
2192              
2193             # return character list
2194 307         745 return \@singleoctet, \@multipleoctet;
2195             }
2196              
2197             #
2198             # Big5-HKSCS octal escape sequence
2199             #
2200             sub octchr {
2201 758     5 0 2860 my($octdigit) = @_;
2202              
2203 5         17 my @binary = ();
2204 5         7 for my $octal (split(//,$octdigit)) {
2205             push @binary, {
2206             '0' => '000',
2207             '1' => '001',
2208             '2' => '010',
2209             '3' => '011',
2210             '4' => '100',
2211             '5' => '101',
2212             '6' => '110',
2213             '7' => '111',
2214 5         25 }->{$octal};
2215             }
2216 50         187 my $binary = join '', @binary;
2217              
2218             my $octchr = {
2219             # 1234567
2220             1 => pack('B*', "0000000$binary"),
2221             2 => pack('B*', "000000$binary"),
2222             3 => pack('B*', "00000$binary"),
2223             4 => pack('B*', "0000$binary"),
2224             5 => pack('B*', "000$binary"),
2225             6 => pack('B*', "00$binary"),
2226             7 => pack('B*', "0$binary"),
2227             0 => pack('B*', "$binary"),
2228              
2229 5         14 }->{CORE::length($binary) % 8};
2230              
2231 5         69 return $octchr;
2232             }
2233              
2234             #
2235             # Big5-HKSCS hexadecimal escape sequence
2236             #
2237             sub hexchr {
2238 5     5 0 20 my($hexdigit) = @_;
2239              
2240             my $hexchr = {
2241             1 => pack('H*', "0$hexdigit"),
2242             0 => pack('H*', "$hexdigit"),
2243              
2244 5         14 }->{CORE::length($_[0]) % 2};
2245              
2246 5         62 return $hexchr;
2247             }
2248              
2249             #
2250             # Big5-HKSCS open character list for qr
2251             #
2252             sub charlist_qr {
2253              
2254 5     519 0 21 my $modifier = pop @_;
2255 519         1025 my @char = @_;
2256              
2257 519         1634 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2258 519         1563 my @singleoctet = @$singleoctet;
2259 519         1119 my @multipleoctet = @$multipleoctet;
2260              
2261             # return character list
2262 519 100       817 if (scalar(@singleoctet) >= 1) {
2263              
2264             # with /i modifier
2265 519 100       1446 if ($modifier =~ m/i/oxms) {
2266 384         879 my %singleoctet_ignorecase = ();
2267 107         156 for (@singleoctet) {
2268 107   100     145 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2269 272         873 for my $ord (hex($1) .. hex($2)) {
2270 80         266 my $char = CORE::chr($ord);
2271 1046         1437 my $uc = Ebig5hkscs::uc($char);
2272 1046         1351 my $fc = Ebig5hkscs::fc($char);
2273 1046 100       1513 if ($uc eq $fc) {
2274 1046         1551 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2275             }
2276             else {
2277 457 50       1073 if (CORE::length($fc) == 1) {
2278 589         742 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2279 589         1209 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2280             }
2281             else {
2282 589         1472 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2283 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2284             }
2285             }
2286             }
2287             }
2288 0 100       0 if ($_ ne '') {
2289 272         463 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2290             }
2291             }
2292 192         462 my $i = 0;
2293 107         138 my @singleoctet_ignorecase = ();
2294 107         136 for my $ord (0 .. 255) {
2295 107 100       165 if (exists $singleoctet_ignorecase{$ord}) {
2296 27392         32586 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1458  
2297             }
2298             else {
2299 1577         2375 $i++;
2300             }
2301             }
2302 25815         27017 @singleoctet = ();
2303 107         163 for my $range (@singleoctet_ignorecase) {
2304 107 100       223 if (ref $range) {
2305 11412 100       17699 if (scalar(@{$range}) == 1) {
  214 50       218  
2306 214         347 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         8  
2307             }
2308 5         58 elsif (scalar(@{$range}) == 2) {
2309 209         356 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2310             }
2311             else {
2312 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         236  
  209         280  
2313             }
2314             }
2315             }
2316             }
2317              
2318 209         940 my $not_anchor = '';
2319 384         589 $not_anchor = '(?![\x81-\xFE])';
2320              
2321 384         917 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2322             }
2323 384 100       1924 if (scalar(@multipleoctet) >= 2) {
2324 519         1537 return '(?:' . join('|', @multipleoctet) . ')';
2325             }
2326             else {
2327 131         789 return $multipleoctet[0];
2328             }
2329             }
2330              
2331             #
2332             # Big5-HKSCS open character list for not qr
2333             #
2334             sub charlist_not_qr {
2335              
2336 388     239 0 1842 my $modifier = pop @_;
2337 239         409 my @char = @_;
2338              
2339 239         541 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2340 239         534 my @singleoctet = @$singleoctet;
2341 239         474 my @multipleoctet = @$multipleoctet;
2342              
2343             # with /i modifier
2344 239 100       395 if ($modifier =~ m/i/oxms) {
2345 239         563 my %singleoctet_ignorecase = ();
2346 128         176 for (@singleoctet) {
2347 128   100     183 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2348 272         879 for my $ord (hex($1) .. hex($2)) {
2349 80         274 my $char = CORE::chr($ord);
2350 1046         1702 my $uc = Ebig5hkscs::uc($char);
2351 1046         1288 my $fc = Ebig5hkscs::fc($char);
2352 1046 100       1551 if ($uc eq $fc) {
2353 1046         1568 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2354             }
2355             else {
2356 457 50       1021 if (CORE::length($fc) == 1) {
2357 589         754 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2358 589         1113 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2359             }
2360             else {
2361 589         1417 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2362 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2363             }
2364             }
2365             }
2366             }
2367 0 100       0 if ($_ ne '') {
2368 272         513 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2369             }
2370             }
2371 192         435 my $i = 0;
2372 128         159 my @singleoctet_ignorecase = ();
2373 128         169 for my $ord (0 .. 255) {
2374 128 100       196 if (exists $singleoctet_ignorecase{$ord}) {
2375 32768         38904 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1490  
2376             }
2377             else {
2378 1577         2577 $i++;
2379             }
2380             }
2381 31191         32767 @singleoctet = ();
2382 128         184 for my $range (@singleoctet_ignorecase) {
2383 128 100       266 if (ref $range) {
2384 11412 100       17981 if (scalar(@{$range}) == 1) {
  214 50       213  
2385 214         378 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         6  
2386             }
2387 5         54 elsif (scalar(@{$range}) == 2) {
2388 209         290 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2389             }
2390             else {
2391 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         316  
  209         265  
2392             }
2393             }
2394             }
2395             }
2396              
2397             # return character list
2398 209 100       889 if (scalar(@multipleoctet) >= 1) {
2399 239 100       479 if (scalar(@singleoctet) >= 1) {
2400              
2401             # any character other than multiple-octet and single octet character class
2402 114         205 return '(?!' . join('|', @multipleoctet) . ')(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2403             }
2404             else {
2405              
2406             # any character other than multiple-octet character class
2407 70         472 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2408             }
2409             }
2410             else {
2411 44 50       267 if (scalar(@singleoctet) >= 1) {
2412              
2413             # any character other than single octet character class
2414 125         281 return '(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2415             }
2416             else {
2417              
2418             # any character
2419 125         689 return "(?:$your_char)";
2420             }
2421             }
2422             }
2423              
2424             #
2425             # open file in read mode
2426             #
2427             sub _open_r {
2428 0     768   0 my(undef,$file) = @_;
2429 389     389   8200 use Fcntl qw(O_RDONLY);
  389         923  
  389         61271  
2430 768         2878 return CORE::sysopen($_[0], $file, &O_RDONLY);
2431             }
2432              
2433             #
2434             # open file in append mode
2435             #
2436             sub _open_a {
2437 768     384   31826 my(undef,$file) = @_;
2438 389     389   4268 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  389         931  
  389         5694839  
2439 384         1127 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2440             }
2441              
2442             #
2443             # safe system
2444             #
2445             sub _systemx {
2446              
2447             # P.707 29.2.33. exec
2448             # in Chapter 29: Functions
2449             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2450             #
2451             # Be aware that in older releases of Perl, exec (and system) did not flush
2452             # your output buffer, so you needed to enable command buffering by setting $|
2453             # on one or more filehandles to avoid lost output in the case of exec, or
2454             # misordererd output in the case of system. This situation was largely remedied
2455             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2456              
2457             # P.855 exec
2458             # in Chapter 27: Functions
2459             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2460             #
2461             # In very old release of Perl (before v5.6), exec (and system) did not flush
2462             # your output buffer, so you needed to enable command buffering by setting $|
2463             # on one or more filehandles to avoid lost output with exec or misordered
2464             # output with system.
2465              
2466 384     384   77543 $| = 1;
2467              
2468             # P.565 23.1.2. Cleaning Up Your Environment
2469             # in Chapter 23: Security
2470             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2471              
2472             # P.656 Cleaning Up Your Environment
2473             # in Chapter 20: Security
2474             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2475              
2476             # local $ENV{'PATH'} = '.';
2477 384         1445 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2478              
2479             # P.707 29.2.33. exec
2480             # in Chapter 29: Functions
2481             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2482             #
2483             # As we mentioned earlier, exec treats a discrete list of arguments as an
2484             # indication that it should bypass shell processing. However, there is one
2485             # place where you might still get tripped up. The exec call (and system, too)
2486             # will not distinguish between a single scalar argument and an array containing
2487             # only one element.
2488             #
2489             # @args = ("echo surprise"); # just one element in list
2490             # exec @args # still subject to shell escapes
2491             # or die "exec: $!"; # because @args == 1
2492             #
2493             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2494             # first argument as the pathname, which forces the rest of the arguments to be
2495             # interpreted as a list, even if there is only one of them:
2496             #
2497             # exec { $args[0] } @args # safe even with one-argument list
2498             # or die "can't exec @args: $!";
2499              
2500             # P.855 exec
2501             # in Chapter 27: Functions
2502             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2503             #
2504             # As we mentioned earlier, exec treats a discrete list of arguments as a
2505             # directive to bypass shell processing. However, there is one place where
2506             # you might still get tripped up. The exec call (and system, too) cannot
2507             # 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             # || die "exec: $!"; # because @args == 1
2513             #
2514             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2515             # 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             # || die "can't exec @args: $!";
2520              
2521 384         12734 return CORE::system { $_[0] } @_; # safe even with one-argument list
  384         901  
2522             }
2523              
2524             #
2525             # Big5-HKSCS order to character (with parameter)
2526             #
2527             sub Ebig5hkscs::chr(;$) {
2528              
2529 384 0   0 0 50359218 my $c = @_ ? $_[0] : $_;
2530              
2531 0 0       0 if ($c == 0x00) {
2532 0         0 return "\x00";
2533             }
2534             else {
2535 0         0 my @chr = ();
2536 0         0 while ($c > 0) {
2537 0         0 unshift @chr, ($c % 0x100);
2538 0         0 $c = int($c / 0x100);
2539             }
2540 0         0 return pack 'C*', @chr;
2541             }
2542             }
2543              
2544             #
2545             # Big5-HKSCS order to character (without parameter)
2546             #
2547             sub Ebig5hkscs::chr_() {
2548              
2549 0     0 0 0 my $c = $_;
2550              
2551 0 0       0 if ($c == 0x00) {
2552 0         0 return "\x00";
2553             }
2554             else {
2555 0         0 my @chr = ();
2556 0         0 while ($c > 0) {
2557 0         0 unshift @chr, ($c % 0x100);
2558 0         0 $c = int($c / 0x100);
2559             }
2560 0         0 return pack 'C*', @chr;
2561             }
2562             }
2563              
2564             #
2565             # Big5-HKSCS stacked file test expr
2566             #
2567             sub Ebig5hkscs::filetest {
2568              
2569 0     0 0 0 my $file = pop @_;
2570 0         0 my $filetest = substr(pop @_, 1);
2571              
2572 0 0       0 unless (CORE::eval qq{Ebig5hkscs::$filetest(\$file)}) {
2573 0         0 return '';
2574             }
2575 0         0 for my $filetest (CORE::reverse @_) {
2576 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
2577 0         0 return '';
2578             }
2579             }
2580 0         0 return 1;
2581             }
2582              
2583             #
2584             # Big5-HKSCS file test -r expr
2585             #
2586             sub Ebig5hkscs::r(;*@) {
2587              
2588 0 0   0 0 0 local $_ = shift if @_;
2589 0 0 0     0 croak 'Too many arguments for -r (Ebig5hkscs::r)' if @_ and not wantarray;
2590              
2591 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2592 0 0       0 return wantarray ? (-r _,@_) : -r _;
2593             }
2594              
2595             # P.908 32.39. Symbol
2596             # in Chapter 32: Standard Modules
2597             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2598              
2599             # P.326 Prototypes
2600             # in Chapter 7: Subroutines
2601             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2602              
2603             # (and so on)
2604              
2605             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2606 0 0       0 return wantarray ? (-r $fh,@_) : -r $fh;
2607             }
2608             elsif (-e $_) {
2609 0 0       0 return wantarray ? (-r _,@_) : -r _;
2610             }
2611             elsif (_MSWin32_5Cended_path($_)) {
2612 0 0       0 if (-d "$_/.") {
2613 0 0       0 return wantarray ? (-r _,@_) : -r _;
2614             }
2615             else {
2616              
2617             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Ebig5hkscs::*()
2618             # on Windows opens the file for the path which has 5c at end.
2619             # (and so on)
2620              
2621 0         0 my $fh = gensym();
2622 0 0       0 if (_open_r($fh, $_)) {
2623 0         0 my $r = -r $fh;
2624 0         0 close $fh;
2625 0 0       0 return wantarray ? ($r,@_) : $r;
2626             }
2627             }
2628             }
2629 0 0       0 return wantarray ? (undef,@_) : undef;
2630             }
2631              
2632             #
2633             # Big5-HKSCS file test -w expr
2634             #
2635             sub Ebig5hkscs::w(;*@) {
2636              
2637 0 0   0 0 0 local $_ = shift if @_;
2638 0 0 0     0 croak 'Too many arguments for -w (Ebig5hkscs::w)' if @_ and not wantarray;
2639              
2640 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2641 0 0       0 return wantarray ? (-w _,@_) : -w _;
2642             }
2643             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2644 0 0       0 return wantarray ? (-w $fh,@_) : -w $fh;
2645             }
2646             elsif (-e $_) {
2647 0 0       0 return wantarray ? (-w _,@_) : -w _;
2648             }
2649             elsif (_MSWin32_5Cended_path($_)) {
2650 0 0       0 if (-d "$_/.") {
2651 0 0       0 return wantarray ? (-w _,@_) : -w _;
2652             }
2653             else {
2654 0         0 my $fh = gensym();
2655 0 0       0 if (_open_a($fh, $_)) {
2656 0         0 my $w = -w $fh;
2657 0         0 close $fh;
2658 0 0       0 return wantarray ? ($w,@_) : $w;
2659             }
2660             }
2661             }
2662 0 0       0 return wantarray ? (undef,@_) : undef;
2663             }
2664              
2665             #
2666             # Big5-HKSCS file test -x expr
2667             #
2668             sub Ebig5hkscs::x(;*@) {
2669              
2670 0 0   0 0 0 local $_ = shift if @_;
2671 0 0 0     0 croak 'Too many arguments for -x (Ebig5hkscs::x)' if @_ and not wantarray;
2672              
2673 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2674 0 0       0 return wantarray ? (-x _,@_) : -x _;
2675             }
2676             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2677 0 0       0 return wantarray ? (-x $fh,@_) : -x $fh;
2678             }
2679             elsif (-e $_) {
2680 0 0       0 return wantarray ? (-x _,@_) : -x _;
2681             }
2682             elsif (_MSWin32_5Cended_path($_)) {
2683 0 0       0 if (-d "$_/.") {
2684 0 0       0 return wantarray ? (-x _,@_) : -x _;
2685             }
2686             else {
2687 0         0 my $fh = gensym();
2688 0 0       0 if (_open_r($fh, $_)) {
2689 0         0 my $dummy_for_underline_cache = -x $fh;
2690 0         0 close $fh;
2691             }
2692              
2693             # filename is not .COM .EXE .BAT .CMD
2694 0 0       0 return wantarray ? ('',@_) : '';
2695             }
2696             }
2697 0 0       0 return wantarray ? (undef,@_) : undef;
2698             }
2699              
2700             #
2701             # Big5-HKSCS file test -o expr
2702             #
2703             sub Ebig5hkscs::o(;*@) {
2704              
2705 0 0   0 0 0 local $_ = shift if @_;
2706 0 0 0     0 croak 'Too many arguments for -o (Ebig5hkscs::o)' if @_ and not wantarray;
2707              
2708 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2709 0 0       0 return wantarray ? (-o _,@_) : -o _;
2710             }
2711             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2712 0 0       0 return wantarray ? (-o $fh,@_) : -o $fh;
2713             }
2714             elsif (-e $_) {
2715 0 0       0 return wantarray ? (-o _,@_) : -o _;
2716             }
2717             elsif (_MSWin32_5Cended_path($_)) {
2718 0 0       0 if (-d "$_/.") {
2719 0 0       0 return wantarray ? (-o _,@_) : -o _;
2720             }
2721             else {
2722 0         0 my $fh = gensym();
2723 0 0       0 if (_open_r($fh, $_)) {
2724 0         0 my $o = -o $fh;
2725 0         0 close $fh;
2726 0 0       0 return wantarray ? ($o,@_) : $o;
2727             }
2728             }
2729             }
2730 0 0       0 return wantarray ? (undef,@_) : undef;
2731             }
2732              
2733             #
2734             # Big5-HKSCS file test -R expr
2735             #
2736             sub Ebig5hkscs::R(;*@) {
2737              
2738 0 0   0 0 0 local $_ = shift if @_;
2739 0 0 0     0 croak 'Too many arguments for -R (Ebig5hkscs::R)' if @_ and not wantarray;
2740              
2741 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2742 0 0       0 return wantarray ? (-R _,@_) : -R _;
2743             }
2744             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2745 0 0       0 return wantarray ? (-R $fh,@_) : -R $fh;
2746             }
2747             elsif (-e $_) {
2748 0 0       0 return wantarray ? (-R _,@_) : -R _;
2749             }
2750             elsif (_MSWin32_5Cended_path($_)) {
2751 0 0       0 if (-d "$_/.") {
2752 0 0       0 return wantarray ? (-R _,@_) : -R _;
2753             }
2754             else {
2755 0         0 my $fh = gensym();
2756 0 0       0 if (_open_r($fh, $_)) {
2757 0         0 my $R = -R $fh;
2758 0         0 close $fh;
2759 0 0       0 return wantarray ? ($R,@_) : $R;
2760             }
2761             }
2762             }
2763 0 0       0 return wantarray ? (undef,@_) : undef;
2764             }
2765              
2766             #
2767             # Big5-HKSCS file test -W expr
2768             #
2769             sub Ebig5hkscs::W(;*@) {
2770              
2771 0 0   0 0 0 local $_ = shift if @_;
2772 0 0 0     0 croak 'Too many arguments for -W (Ebig5hkscs::W)' if @_ and not wantarray;
2773              
2774 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2775 0 0       0 return wantarray ? (-W _,@_) : -W _;
2776             }
2777             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2778 0 0       0 return wantarray ? (-W $fh,@_) : -W $fh;
2779             }
2780             elsif (-e $_) {
2781 0 0       0 return wantarray ? (-W _,@_) : -W _;
2782             }
2783             elsif (_MSWin32_5Cended_path($_)) {
2784 0 0       0 if (-d "$_/.") {
2785 0 0       0 return wantarray ? (-W _,@_) : -W _;
2786             }
2787             else {
2788 0         0 my $fh = gensym();
2789 0 0       0 if (_open_a($fh, $_)) {
2790 0         0 my $W = -W $fh;
2791 0         0 close $fh;
2792 0 0       0 return wantarray ? ($W,@_) : $W;
2793             }
2794             }
2795             }
2796 0 0       0 return wantarray ? (undef,@_) : undef;
2797             }
2798              
2799             #
2800             # Big5-HKSCS file test -X expr
2801             #
2802             sub Ebig5hkscs::X(;*@) {
2803              
2804 0 0   0 1 0 local $_ = shift if @_;
2805 0 0 0     0 croak 'Too many arguments for -X (Ebig5hkscs::X)' if @_ and not wantarray;
2806              
2807 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2808 0 0       0 return wantarray ? (-X _,@_) : -X _;
2809             }
2810             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2811 0 0       0 return wantarray ? (-X $fh,@_) : -X $fh;
2812             }
2813             elsif (-e $_) {
2814 0 0       0 return wantarray ? (-X _,@_) : -X _;
2815             }
2816             elsif (_MSWin32_5Cended_path($_)) {
2817 0 0       0 if (-d "$_/.") {
2818 0 0       0 return wantarray ? (-X _,@_) : -X _;
2819             }
2820             else {
2821 0         0 my $fh = gensym();
2822 0 0       0 if (_open_r($fh, $_)) {
2823 0         0 my $dummy_for_underline_cache = -X $fh;
2824 0         0 close $fh;
2825             }
2826              
2827             # filename is not .COM .EXE .BAT .CMD
2828 0 0       0 return wantarray ? ('',@_) : '';
2829             }
2830             }
2831 0 0       0 return wantarray ? (undef,@_) : undef;
2832             }
2833              
2834             #
2835             # Big5-HKSCS file test -O expr
2836             #
2837             sub Ebig5hkscs::O(;*@) {
2838              
2839 0 0   0 0 0 local $_ = shift if @_;
2840 0 0 0     0 croak 'Too many arguments for -O (Ebig5hkscs::O)' if @_ and not wantarray;
2841              
2842 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2843 0 0       0 return wantarray ? (-O _,@_) : -O _;
2844             }
2845             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2846 0 0       0 return wantarray ? (-O $fh,@_) : -O $fh;
2847             }
2848             elsif (-e $_) {
2849 0 0       0 return wantarray ? (-O _,@_) : -O _;
2850             }
2851             elsif (_MSWin32_5Cended_path($_)) {
2852 0 0       0 if (-d "$_/.") {
2853 0 0       0 return wantarray ? (-O _,@_) : -O _;
2854             }
2855             else {
2856 0         0 my $fh = gensym();
2857 0 0       0 if (_open_r($fh, $_)) {
2858 0         0 my $O = -O $fh;
2859 0         0 close $fh;
2860 0 0       0 return wantarray ? ($O,@_) : $O;
2861             }
2862             }
2863             }
2864 0 0       0 return wantarray ? (undef,@_) : undef;
2865             }
2866              
2867             #
2868             # Big5-HKSCS file test -e expr
2869             #
2870             sub Ebig5hkscs::e(;*@) {
2871              
2872 0 50   768 0 0 local $_ = shift if @_;
2873 768 50 33     2911 croak 'Too many arguments for -e (Ebig5hkscs::e)' if @_ and not wantarray;
2874              
2875 768         3062 local $^W = 0;
2876              
2877 768         2588 my $fh = qualify_to_ref $_;
2878 768 50       2113 if ($_ eq '_') {
    50          
    50          
    50          
    50          
2879 768 0       3939 return wantarray ? (-e _,@_) : -e _;
2880             }
2881              
2882             # return false if directory handle
2883             elsif (defined Ebig5hkscs::telldir($fh)) {
2884 0 0       0 return wantarray ? ('',@_) : '';
2885             }
2886              
2887             # return true if file handle
2888             elsif (defined fileno $fh) {
2889 0 0       0 return wantarray ? (1,@_) : 1;
2890             }
2891              
2892             elsif (-e $_) {
2893 0 0       0 return wantarray ? (1,@_) : 1;
2894             }
2895             elsif (_MSWin32_5Cended_path($_)) {
2896 0 0       0 if (-d "$_/.") {
2897 0 0       0 return wantarray ? (1,@_) : 1;
2898             }
2899             else {
2900 0         0 my $fh = gensym();
2901 0 0       0 if (_open_r($fh, $_)) {
2902 0         0 my $e = -e $fh;
2903 0         0 close $fh;
2904 0 0       0 return wantarray ? ($e,@_) : $e;
2905             }
2906             }
2907             }
2908 0 50       0 return wantarray ? (undef,@_) : undef;
2909             }
2910              
2911             #
2912             # Big5-HKSCS file test -z expr
2913             #
2914             sub Ebig5hkscs::z(;*@) {
2915              
2916 768 0   0 0 4380 local $_ = shift if @_;
2917 0 0 0     0 croak 'Too many arguments for -z (Ebig5hkscs::z)' if @_ and not wantarray;
2918              
2919 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2920 0 0       0 return wantarray ? (-z _,@_) : -z _;
2921             }
2922             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2923 0 0       0 return wantarray ? (-z $fh,@_) : -z $fh;
2924             }
2925             elsif (-e $_) {
2926 0 0       0 return wantarray ? (-z _,@_) : -z _;
2927             }
2928             elsif (_MSWin32_5Cended_path($_)) {
2929 0 0       0 if (-d "$_/.") {
2930 0 0       0 return wantarray ? (-z _,@_) : -z _;
2931             }
2932             else {
2933 0         0 my $fh = gensym();
2934 0 0       0 if (_open_r($fh, $_)) {
2935 0         0 my $z = -z $fh;
2936 0         0 close $fh;
2937 0 0       0 return wantarray ? ($z,@_) : $z;
2938             }
2939             }
2940             }
2941 0 0       0 return wantarray ? (undef,@_) : undef;
2942             }
2943              
2944             #
2945             # Big5-HKSCS file test -s expr
2946             #
2947             sub Ebig5hkscs::s(;*@) {
2948              
2949 0 0   0 0 0 local $_ = shift if @_;
2950 0 0 0     0 croak 'Too many arguments for -s (Ebig5hkscs::s)' if @_ and not wantarray;
2951              
2952 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2953 0 0       0 return wantarray ? (-s _,@_) : -s _;
2954             }
2955             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2956 0 0       0 return wantarray ? (-s $fh,@_) : -s $fh;
2957             }
2958             elsif (-e $_) {
2959 0 0       0 return wantarray ? (-s _,@_) : -s _;
2960             }
2961             elsif (_MSWin32_5Cended_path($_)) {
2962 0 0       0 if (-d "$_/.") {
2963 0 0       0 return wantarray ? (-s _,@_) : -s _;
2964             }
2965             else {
2966 0         0 my $fh = gensym();
2967 0 0       0 if (_open_r($fh, $_)) {
2968 0         0 my $s = -s $fh;
2969 0         0 close $fh;
2970 0 0       0 return wantarray ? ($s,@_) : $s;
2971             }
2972             }
2973             }
2974 0 0       0 return wantarray ? (undef,@_) : undef;
2975             }
2976              
2977             #
2978             # Big5-HKSCS file test -f expr
2979             #
2980             sub Ebig5hkscs::f(;*@) {
2981              
2982 0 0   0 0 0 local $_ = shift if @_;
2983 0 0 0     0 croak 'Too many arguments for -f (Ebig5hkscs::f)' if @_ and not wantarray;
2984              
2985 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2986 0 0       0 return wantarray ? (-f _,@_) : -f _;
2987             }
2988             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2989 0 0       0 return wantarray ? (-f $fh,@_) : -f $fh;
2990             }
2991             elsif (-e $_) {
2992 0 0       0 return wantarray ? (-f _,@_) : -f _;
2993             }
2994             elsif (_MSWin32_5Cended_path($_)) {
2995 0 0       0 if (-d "$_/.") {
2996 0 0       0 return wantarray ? ('',@_) : '';
2997             }
2998             else {
2999 0         0 my $fh = gensym();
3000 0 0       0 if (_open_r($fh, $_)) {
3001 0         0 my $f = -f $fh;
3002 0         0 close $fh;
3003 0 0       0 return wantarray ? ($f,@_) : $f;
3004             }
3005             }
3006             }
3007 0 0       0 return wantarray ? (undef,@_) : undef;
3008             }
3009              
3010             #
3011             # Big5-HKSCS file test -d expr
3012             #
3013             sub Ebig5hkscs::d(;*@) {
3014              
3015 0 0   0 0 0 local $_ = shift if @_;
3016 0 0 0     0 croak 'Too many arguments for -d (Ebig5hkscs::d)' if @_ and not wantarray;
3017              
3018 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3019 0 0       0 return wantarray ? (-d _,@_) : -d _;
3020             }
3021              
3022             # return false if file handle or directory handle
3023             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3024 0 0       0 return wantarray ? ('',@_) : '';
3025             }
3026             elsif (-e $_) {
3027 0 0       0 return wantarray ? (-d _,@_) : -d _;
3028             }
3029             elsif (_MSWin32_5Cended_path($_)) {
3030 0 0       0 return wantarray ? (-d "$_/.",@_) : -d "$_/.";
3031             }
3032 0 0       0 return wantarray ? (undef,@_) : undef;
3033             }
3034              
3035             #
3036             # Big5-HKSCS file test -l expr
3037             #
3038             sub Ebig5hkscs::l(;*@) {
3039              
3040 0 0   0 0 0 local $_ = shift if @_;
3041 0 0 0     0 croak 'Too many arguments for -l (Ebig5hkscs::l)' if @_ and not wantarray;
3042              
3043 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3044 0 0       0 return wantarray ? (-l _,@_) : -l _;
3045             }
3046             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3047 0 0       0 return wantarray ? (-l $fh,@_) : -l $fh;
3048             }
3049             elsif (-e $_) {
3050 0 0       0 return wantarray ? (-l _,@_) : -l _;
3051             }
3052             elsif (_MSWin32_5Cended_path($_)) {
3053 0 0       0 if (-d "$_/.") {
3054 0 0       0 return wantarray ? (-l _,@_) : -l _;
3055             }
3056             else {
3057 0         0 my $fh = gensym();
3058 0 0       0 if (_open_r($fh, $_)) {
3059 0         0 my $l = -l $fh;
3060 0         0 close $fh;
3061 0 0       0 return wantarray ? ($l,@_) : $l;
3062             }
3063             }
3064             }
3065 0 0       0 return wantarray ? (undef,@_) : undef;
3066             }
3067              
3068             #
3069             # Big5-HKSCS file test -p expr
3070             #
3071             sub Ebig5hkscs::p(;*@) {
3072              
3073 0 0   0 0 0 local $_ = shift if @_;
3074 0 0 0     0 croak 'Too many arguments for -p (Ebig5hkscs::p)' if @_ and not wantarray;
3075              
3076 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3077 0 0       0 return wantarray ? (-p _,@_) : -p _;
3078             }
3079             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3080 0 0       0 return wantarray ? (-p $fh,@_) : -p $fh;
3081             }
3082             elsif (-e $_) {
3083 0 0       0 return wantarray ? (-p _,@_) : -p _;
3084             }
3085             elsif (_MSWin32_5Cended_path($_)) {
3086 0 0       0 if (-d "$_/.") {
3087 0 0       0 return wantarray ? (-p _,@_) : -p _;
3088             }
3089             else {
3090 0         0 my $fh = gensym();
3091 0 0       0 if (_open_r($fh, $_)) {
3092 0         0 my $p = -p $fh;
3093 0         0 close $fh;
3094 0 0       0 return wantarray ? ($p,@_) : $p;
3095             }
3096             }
3097             }
3098 0 0       0 return wantarray ? (undef,@_) : undef;
3099             }
3100              
3101             #
3102             # Big5-HKSCS file test -S expr
3103             #
3104             sub Ebig5hkscs::S(;*@) {
3105              
3106 0 0   0 0 0 local $_ = shift if @_;
3107 0 0 0     0 croak 'Too many arguments for -S (Ebig5hkscs::S)' if @_ and not wantarray;
3108              
3109 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3110 0 0       0 return wantarray ? (-S _,@_) : -S _;
3111             }
3112             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3113 0 0       0 return wantarray ? (-S $fh,@_) : -S $fh;
3114             }
3115             elsif (-e $_) {
3116 0 0       0 return wantarray ? (-S _,@_) : -S _;
3117             }
3118             elsif (_MSWin32_5Cended_path($_)) {
3119 0 0       0 if (-d "$_/.") {
3120 0 0       0 return wantarray ? (-S _,@_) : -S _;
3121             }
3122             else {
3123 0         0 my $fh = gensym();
3124 0 0       0 if (_open_r($fh, $_)) {
3125 0         0 my $S = -S $fh;
3126 0         0 close $fh;
3127 0 0       0 return wantarray ? ($S,@_) : $S;
3128             }
3129             }
3130             }
3131 0 0       0 return wantarray ? (undef,@_) : undef;
3132             }
3133              
3134             #
3135             # Big5-HKSCS file test -b expr
3136             #
3137             sub Ebig5hkscs::b(;*@) {
3138              
3139 0 0   0 0 0 local $_ = shift if @_;
3140 0 0 0     0 croak 'Too many arguments for -b (Ebig5hkscs::b)' if @_ and not wantarray;
3141              
3142 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3143 0 0       0 return wantarray ? (-b _,@_) : -b _;
3144             }
3145             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3146 0 0       0 return wantarray ? (-b $fh,@_) : -b $fh;
3147             }
3148             elsif (-e $_) {
3149 0 0       0 return wantarray ? (-b _,@_) : -b _;
3150             }
3151             elsif (_MSWin32_5Cended_path($_)) {
3152 0 0       0 if (-d "$_/.") {
3153 0 0       0 return wantarray ? (-b _,@_) : -b _;
3154             }
3155             else {
3156 0         0 my $fh = gensym();
3157 0 0       0 if (_open_r($fh, $_)) {
3158 0         0 my $b = -b $fh;
3159 0         0 close $fh;
3160 0 0       0 return wantarray ? ($b,@_) : $b;
3161             }
3162             }
3163             }
3164 0 0       0 return wantarray ? (undef,@_) : undef;
3165             }
3166              
3167             #
3168             # Big5-HKSCS file test -c expr
3169             #
3170             sub Ebig5hkscs::c(;*@) {
3171              
3172 0 0   0 0 0 local $_ = shift if @_;
3173 0 0 0     0 croak 'Too many arguments for -c (Ebig5hkscs::c)' if @_ and not wantarray;
3174              
3175 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3176 0 0       0 return wantarray ? (-c _,@_) : -c _;
3177             }
3178             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3179 0 0       0 return wantarray ? (-c $fh,@_) : -c $fh;
3180             }
3181             elsif (-e $_) {
3182 0 0       0 return wantarray ? (-c _,@_) : -c _;
3183             }
3184             elsif (_MSWin32_5Cended_path($_)) {
3185 0 0       0 if (-d "$_/.") {
3186 0 0       0 return wantarray ? (-c _,@_) : -c _;
3187             }
3188             else {
3189 0         0 my $fh = gensym();
3190 0 0       0 if (_open_r($fh, $_)) {
3191 0         0 my $c = -c $fh;
3192 0         0 close $fh;
3193 0 0       0 return wantarray ? ($c,@_) : $c;
3194             }
3195             }
3196             }
3197 0 0       0 return wantarray ? (undef,@_) : undef;
3198             }
3199              
3200             #
3201             # Big5-HKSCS file test -u expr
3202             #
3203             sub Ebig5hkscs::u(;*@) {
3204              
3205 0 0   0 0 0 local $_ = shift if @_;
3206 0 0 0     0 croak 'Too many arguments for -u (Ebig5hkscs::u)' if @_ and not wantarray;
3207              
3208 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3209 0 0       0 return wantarray ? (-u _,@_) : -u _;
3210             }
3211             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3212 0 0       0 return wantarray ? (-u $fh,@_) : -u $fh;
3213             }
3214             elsif (-e $_) {
3215 0 0       0 return wantarray ? (-u _,@_) : -u _;
3216             }
3217             elsif (_MSWin32_5Cended_path($_)) {
3218 0 0       0 if (-d "$_/.") {
3219 0 0       0 return wantarray ? (-u _,@_) : -u _;
3220             }
3221             else {
3222 0         0 my $fh = gensym();
3223 0 0       0 if (_open_r($fh, $_)) {
3224 0         0 my $u = -u $fh;
3225 0         0 close $fh;
3226 0 0       0 return wantarray ? ($u,@_) : $u;
3227             }
3228             }
3229             }
3230 0 0       0 return wantarray ? (undef,@_) : undef;
3231             }
3232              
3233             #
3234             # Big5-HKSCS file test -g expr
3235             #
3236             sub Ebig5hkscs::g(;*@) {
3237              
3238 0 0   0 0 0 local $_ = shift if @_;
3239 0 0 0     0 croak 'Too many arguments for -g (Ebig5hkscs::g)' if @_ and not wantarray;
3240              
3241 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3242 0 0       0 return wantarray ? (-g _,@_) : -g _;
3243             }
3244             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3245 0 0       0 return wantarray ? (-g $fh,@_) : -g $fh;
3246             }
3247             elsif (-e $_) {
3248 0 0       0 return wantarray ? (-g _,@_) : -g _;
3249             }
3250             elsif (_MSWin32_5Cended_path($_)) {
3251 0 0       0 if (-d "$_/.") {
3252 0 0       0 return wantarray ? (-g _,@_) : -g _;
3253             }
3254             else {
3255 0         0 my $fh = gensym();
3256 0 0       0 if (_open_r($fh, $_)) {
3257 0         0 my $g = -g $fh;
3258 0         0 close $fh;
3259 0 0       0 return wantarray ? ($g,@_) : $g;
3260             }
3261             }
3262             }
3263 0 0       0 return wantarray ? (undef,@_) : undef;
3264             }
3265              
3266             #
3267             # Big5-HKSCS file test -k expr
3268             #
3269             sub Ebig5hkscs::k(;*@) {
3270              
3271 0 0   0 0 0 local $_ = shift if @_;
3272 0 0 0     0 croak 'Too many arguments for -k (Ebig5hkscs::k)' if @_ and not wantarray;
3273              
3274 0 0       0 if ($_ eq '_') {
    0          
    0          
3275 0 0       0 return wantarray ? ('',@_) : '';
3276             }
3277             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3278 0 0       0 return wantarray ? ('',@_) : '';
3279             }
3280             elsif ($] =~ /^5\.008/oxms) {
3281 0 0       0 return wantarray ? ('',@_) : '';
3282             }
3283 0 0       0 return wantarray ? ($_,@_) : $_;
3284             }
3285              
3286             #
3287             # Big5-HKSCS file test -T expr
3288             #
3289             sub Ebig5hkscs::T(;*@) {
3290              
3291 0 0   0 0 0 local $_ = shift if @_;
3292              
3293             # Use of croak without parentheses makes die on Strawberry Perl 5.008 and 5.010, like:
3294             # croak 'Too many arguments for -T (Ebig5hkscs::T)';
3295             # Must be used by parentheses like:
3296             # croak('Too many arguments for -T (Ebig5hkscs::T)');
3297              
3298 0 0 0     0 if (@_ and not wantarray) {
3299 0         0 croak('Too many arguments for -T (Ebig5hkscs::T)');
3300             }
3301              
3302 0         0 my $T = 1;
3303              
3304 0         0 my $fh = qualify_to_ref $_;
3305 0 0       0 if (defined fileno $fh) {
3306              
3307 0 0       0 if (defined Ebig5hkscs::telldir($fh)) {
3308 0 0       0 return wantarray ? (undef,@_) : undef;
3309             }
3310              
3311             # P.813 29.2.176. tell
3312             # in Chapter 29: Functions
3313             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3314              
3315             # P.970 tell
3316             # in Chapter 27: Functions
3317             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3318              
3319             # (and so on)
3320              
3321 0         0 my $systell = sysseek $fh, 0, 1;
3322              
3323 0 0       0 if (sysread $fh, my $block, 512) {
3324              
3325             # P.163 Binary file check in Little Perl Parlor 16
3326             # of Book No. T1008901080816 ZASSHI 08901-8 UNIX MAGAZINE 1993 Aug VOL8#8
3327             # (and so on)
3328              
3329 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3330 0         0 $T = '';
3331             }
3332             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3333 0         0 $T = '';
3334             }
3335             }
3336              
3337             # 0 byte or eof
3338             else {
3339 0         0 $T = 1;
3340             }
3341              
3342 0         0 my $dummy_for_underline_cache = -T $fh;
3343 0         0 sysseek $fh, $systell, 0;
3344             }
3345             else {
3346 0 0 0     0 if (-d $_ or -d "$_/.") {
3347 0 0       0 return wantarray ? (undef,@_) : undef;
3348             }
3349              
3350 0         0 $fh = gensym();
3351 0 0       0 if (_open_r($fh, $_)) {
3352             }
3353             else {
3354 0 0       0 return wantarray ? (undef,@_) : undef;
3355             }
3356 0 0       0 if (sysread $fh, my $block, 512) {
3357 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3358 0         0 $T = '';
3359             }
3360             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3361 0         0 $T = '';
3362             }
3363             }
3364              
3365             # 0 byte or eof
3366             else {
3367 0         0 $T = 1;
3368             }
3369 0         0 my $dummy_for_underline_cache = -T $fh;
3370 0         0 close $fh;
3371             }
3372              
3373 0 0       0 return wantarray ? ($T,@_) : $T;
3374             }
3375              
3376             #
3377             # Big5-HKSCS file test -B expr
3378             #
3379             sub Ebig5hkscs::B(;*@) {
3380              
3381 0 0   0 0 0 local $_ = shift if @_;
3382 0 0 0     0 croak 'Too many arguments for -B (Ebig5hkscs::B)' if @_ and not wantarray;
3383 0         0 my $B = '';
3384              
3385 0         0 my $fh = qualify_to_ref $_;
3386 0 0       0 if (defined fileno $fh) {
3387              
3388 0 0       0 if (defined Ebig5hkscs::telldir($fh)) {
3389 0 0       0 return wantarray ? (undef,@_) : undef;
3390             }
3391              
3392 0         0 my $systell = sysseek $fh, 0, 1;
3393              
3394 0 0       0 if (sysread $fh, my $block, 512) {
3395 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3396 0         0 $B = 1;
3397             }
3398             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3399 0         0 $B = 1;
3400             }
3401             }
3402              
3403             # 0 byte or eof
3404             else {
3405 0         0 $B = 1;
3406             }
3407              
3408 0         0 my $dummy_for_underline_cache = -B $fh;
3409 0         0 sysseek $fh, $systell, 0;
3410             }
3411             else {
3412 0 0 0     0 if (-d $_ or -d "$_/.") {
3413 0 0       0 return wantarray ? (undef,@_) : undef;
3414             }
3415              
3416 0         0 $fh = gensym();
3417 0 0       0 if (_open_r($fh, $_)) {
3418             }
3419             else {
3420 0 0       0 return wantarray ? (undef,@_) : undef;
3421             }
3422 0 0       0 if (sysread $fh, my $block, 512) {
3423 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3424 0         0 $B = 1;
3425             }
3426             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3427 0         0 $B = 1;
3428             }
3429             }
3430              
3431             # 0 byte or eof
3432             else {
3433 0         0 $B = 1;
3434             }
3435 0         0 my $dummy_for_underline_cache = -B $fh;
3436 0         0 close $fh;
3437             }
3438              
3439 0 0       0 return wantarray ? ($B,@_) : $B;
3440             }
3441              
3442             #
3443             # Big5-HKSCS file test -M expr
3444             #
3445             sub Ebig5hkscs::M(;*@) {
3446              
3447 0 0   0 0 0 local $_ = shift if @_;
3448 0 0 0     0 croak 'Too many arguments for -M (Ebig5hkscs::M)' if @_ and not wantarray;
3449              
3450 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3451 0 0       0 return wantarray ? (-M _,@_) : -M _;
3452             }
3453             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3454 0 0       0 return wantarray ? (-M $fh,@_) : -M $fh;
3455             }
3456             elsif (-e $_) {
3457 0 0       0 return wantarray ? (-M _,@_) : -M _;
3458             }
3459             elsif (_MSWin32_5Cended_path($_)) {
3460 0 0       0 if (-d "$_/.") {
3461 0 0       0 return wantarray ? (-M _,@_) : -M _;
3462             }
3463             else {
3464 0         0 my $fh = gensym();
3465 0 0       0 if (_open_r($fh, $_)) {
3466 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3467 0         0 close $fh;
3468 0         0 my $M = ($^T - $mtime) / (24*60*60);
3469 0 0       0 return wantarray ? ($M,@_) : $M;
3470             }
3471             }
3472             }
3473 0 0       0 return wantarray ? (undef,@_) : undef;
3474             }
3475              
3476             #
3477             # Big5-HKSCS file test -A expr
3478             #
3479             sub Ebig5hkscs::A(;*@) {
3480              
3481 0 0   0 0 0 local $_ = shift if @_;
3482 0 0 0     0 croak 'Too many arguments for -A (Ebig5hkscs::A)' if @_ and not wantarray;
3483              
3484 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3485 0 0       0 return wantarray ? (-A _,@_) : -A _;
3486             }
3487             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3488 0 0       0 return wantarray ? (-A $fh,@_) : -A $fh;
3489             }
3490             elsif (-e $_) {
3491 0 0       0 return wantarray ? (-A _,@_) : -A _;
3492             }
3493             elsif (_MSWin32_5Cended_path($_)) {
3494 0 0       0 if (-d "$_/.") {
3495 0 0       0 return wantarray ? (-A _,@_) : -A _;
3496             }
3497             else {
3498 0         0 my $fh = gensym();
3499 0 0       0 if (_open_r($fh, $_)) {
3500 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3501 0         0 close $fh;
3502 0         0 my $A = ($^T - $atime) / (24*60*60);
3503 0 0       0 return wantarray ? ($A,@_) : $A;
3504             }
3505             }
3506             }
3507 0 0       0 return wantarray ? (undef,@_) : undef;
3508             }
3509              
3510             #
3511             # Big5-HKSCS file test -C expr
3512             #
3513             sub Ebig5hkscs::C(;*@) {
3514              
3515 0 0   0 0 0 local $_ = shift if @_;
3516 0 0 0     0 croak 'Too many arguments for -C (Ebig5hkscs::C)' if @_ and not wantarray;
3517              
3518 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3519 0 0       0 return wantarray ? (-C _,@_) : -C _;
3520             }
3521             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3522 0 0       0 return wantarray ? (-C $fh,@_) : -C $fh;
3523             }
3524             elsif (-e $_) {
3525 0 0       0 return wantarray ? (-C _,@_) : -C _;
3526             }
3527             elsif (_MSWin32_5Cended_path($_)) {
3528 0 0       0 if (-d "$_/.") {
3529 0 0       0 return wantarray ? (-C _,@_) : -C _;
3530             }
3531             else {
3532 0         0 my $fh = gensym();
3533 0 0       0 if (_open_r($fh, $_)) {
3534 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3535 0         0 close $fh;
3536 0         0 my $C = ($^T - $ctime) / (24*60*60);
3537 0 0       0 return wantarray ? ($C,@_) : $C;
3538             }
3539             }
3540             }
3541 0 0       0 return wantarray ? (undef,@_) : undef;
3542             }
3543              
3544             #
3545             # Big5-HKSCS stacked file test $_
3546             #
3547             sub Ebig5hkscs::filetest_ {
3548              
3549 0     0 0 0 my $filetest = substr(pop @_, 1);
3550              
3551 0 0       0 unless (CORE::eval qq{Ebig5hkscs::${filetest}_}) {
3552 0         0 return '';
3553             }
3554 0         0 for my $filetest (CORE::reverse @_) {
3555 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
3556 0         0 return '';
3557             }
3558             }
3559 0         0 return 1;
3560             }
3561              
3562             #
3563             # Big5-HKSCS file test -r $_
3564             #
3565             sub Ebig5hkscs::r_() {
3566              
3567 0 0   0 0 0 if (-e $_) {
    0          
3568 0 0       0 return -r _ ? 1 : '';
3569             }
3570             elsif (_MSWin32_5Cended_path($_)) {
3571 0 0       0 if (-d "$_/.") {
3572 0 0       0 return -r _ ? 1 : '';
3573             }
3574             else {
3575 0         0 my $fh = gensym();
3576 0 0       0 if (_open_r($fh, $_)) {
3577 0         0 my $r = -r $fh;
3578 0         0 close $fh;
3579 0 0       0 return $r ? 1 : '';
3580             }
3581             }
3582             }
3583              
3584             # 10.10. Returning Failure
3585             # in Chapter 10. Subroutines
3586             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3587             # (and so on)
3588              
3589             # 2010-01-26 The difference of "return;" and "return undef;"
3590             # http://d.hatena.ne.jp/gfx/20100126/1264474754
3591             #
3592             # "Perl Best Practices" recommends to use "return;"*1 to return nothing, but
3593             # it might be wrong in some cases. If you use this idiom for those functions
3594             # which are expected to return a scalar value, e.g. searching functions, the
3595             # user of those functions will be surprised at what they return in list
3596             # context, an empty list - note that many functions and all the methods
3597             # evaluate their arguments in list context. You'd better to use "return undef;"
3598             # for such scalar functions.
3599             #
3600             # sub search_something {
3601             # my($arg) = @_;
3602             # # search_something...
3603             # if(defined $found){
3604             # return $found;
3605             # }
3606             # return; # XXX: you'd better to "return undef;"
3607             # }
3608             #
3609             # # ...
3610             #
3611             # # you'll get what you want, but ...
3612             # my $something = search_something($source);
3613             #
3614             # # you won't get what you want here.
3615             # # @_ for doit() is (-foo => $opt), not (undef, -foo => $opt).
3616             # $obj->doit(search_something($source), -option=> $optval);
3617             #
3618             # # you have to use the "scalar" operator in such a case.
3619             # $obj->doit(scalar search_something($source), ...);
3620             #
3621             # *1: it returns an empty list in list context, or returns undef in scalar
3622             # context
3623             #
3624             # (and so on)
3625              
3626 0         0 return undef;
3627             }
3628              
3629             #
3630             # Big5-HKSCS file test -w $_
3631             #
3632             sub Ebig5hkscs::w_() {
3633              
3634 0 0   0 0 0 if (-e $_) {
    0          
3635 0 0       0 return -w _ ? 1 : '';
3636             }
3637             elsif (_MSWin32_5Cended_path($_)) {
3638 0 0       0 if (-d "$_/.") {
3639 0 0       0 return -w _ ? 1 : '';
3640             }
3641             else {
3642 0         0 my $fh = gensym();
3643 0 0       0 if (_open_a($fh, $_)) {
3644 0         0 my $w = -w $fh;
3645 0         0 close $fh;
3646 0 0       0 return $w ? 1 : '';
3647             }
3648             }
3649             }
3650 0         0 return undef;
3651             }
3652              
3653             #
3654             # Big5-HKSCS file test -x $_
3655             #
3656             sub Ebig5hkscs::x_() {
3657              
3658 0 0   0 0 0 if (-e $_) {
    0          
3659 0 0       0 return -x _ ? 1 : '';
3660             }
3661             elsif (_MSWin32_5Cended_path($_)) {
3662 0 0       0 if (-d "$_/.") {
3663 0 0       0 return -x _ ? 1 : '';
3664             }
3665             else {
3666 0         0 my $fh = gensym();
3667 0 0       0 if (_open_r($fh, $_)) {
3668 0         0 my $dummy_for_underline_cache = -x $fh;
3669 0         0 close $fh;
3670             }
3671              
3672             # filename is not .COM .EXE .BAT .CMD
3673 0         0 return '';
3674             }
3675             }
3676 0         0 return undef;
3677             }
3678              
3679             #
3680             # Big5-HKSCS file test -o $_
3681             #
3682             sub Ebig5hkscs::o_() {
3683              
3684 0 0   0 0 0 if (-e $_) {
    0          
3685 0 0       0 return -o _ ? 1 : '';
3686             }
3687             elsif (_MSWin32_5Cended_path($_)) {
3688 0 0       0 if (-d "$_/.") {
3689 0 0       0 return -o _ ? 1 : '';
3690             }
3691             else {
3692 0         0 my $fh = gensym();
3693 0 0       0 if (_open_r($fh, $_)) {
3694 0         0 my $o = -o $fh;
3695 0         0 close $fh;
3696 0 0       0 return $o ? 1 : '';
3697             }
3698             }
3699             }
3700 0         0 return undef;
3701             }
3702              
3703             #
3704             # Big5-HKSCS file test -R $_
3705             #
3706             sub Ebig5hkscs::R_() {
3707              
3708 0 0   0 0 0 if (-e $_) {
    0          
3709 0 0       0 return -R _ ? 1 : '';
3710             }
3711             elsif (_MSWin32_5Cended_path($_)) {
3712 0 0       0 if (-d "$_/.") {
3713 0 0       0 return -R _ ? 1 : '';
3714             }
3715             else {
3716 0         0 my $fh = gensym();
3717 0 0       0 if (_open_r($fh, $_)) {
3718 0         0 my $R = -R $fh;
3719 0         0 close $fh;
3720 0 0       0 return $R ? 1 : '';
3721             }
3722             }
3723             }
3724 0         0 return undef;
3725             }
3726              
3727             #
3728             # Big5-HKSCS file test -W $_
3729             #
3730             sub Ebig5hkscs::W_() {
3731              
3732 0 0   0 0 0 if (-e $_) {
    0          
3733 0 0       0 return -W _ ? 1 : '';
3734             }
3735             elsif (_MSWin32_5Cended_path($_)) {
3736 0 0       0 if (-d "$_/.") {
3737 0 0       0 return -W _ ? 1 : '';
3738             }
3739             else {
3740 0         0 my $fh = gensym();
3741 0 0       0 if (_open_a($fh, $_)) {
3742 0         0 my $W = -W $fh;
3743 0         0 close $fh;
3744 0 0       0 return $W ? 1 : '';
3745             }
3746             }
3747             }
3748 0         0 return undef;
3749             }
3750              
3751             #
3752             # Big5-HKSCS file test -X $_
3753             #
3754             sub Ebig5hkscs::X_() {
3755              
3756 0 0   0 0 0 if (-e $_) {
    0          
3757 0 0       0 return -X _ ? 1 : '';
3758             }
3759             elsif (_MSWin32_5Cended_path($_)) {
3760 0 0       0 if (-d "$_/.") {
3761 0 0       0 return -X _ ? 1 : '';
3762             }
3763             else {
3764 0         0 my $fh = gensym();
3765 0 0       0 if (_open_r($fh, $_)) {
3766 0         0 my $dummy_for_underline_cache = -X $fh;
3767 0         0 close $fh;
3768             }
3769              
3770             # filename is not .COM .EXE .BAT .CMD
3771 0         0 return '';
3772             }
3773             }
3774 0         0 return undef;
3775             }
3776              
3777             #
3778             # Big5-HKSCS file test -O $_
3779             #
3780             sub Ebig5hkscs::O_() {
3781              
3782 0 0   0 0 0 if (-e $_) {
    0          
3783 0 0       0 return -O _ ? 1 : '';
3784             }
3785             elsif (_MSWin32_5Cended_path($_)) {
3786 0 0       0 if (-d "$_/.") {
3787 0 0       0 return -O _ ? 1 : '';
3788             }
3789             else {
3790 0         0 my $fh = gensym();
3791 0 0       0 if (_open_r($fh, $_)) {
3792 0         0 my $O = -O $fh;
3793 0         0 close $fh;
3794 0 0       0 return $O ? 1 : '';
3795             }
3796             }
3797             }
3798 0         0 return undef;
3799             }
3800              
3801             #
3802             # Big5-HKSCS file test -e $_
3803             #
3804             sub Ebig5hkscs::e_() {
3805              
3806 0 0   0 0 0 if (-e $_) {
    0          
3807 0         0 return 1;
3808             }
3809             elsif (_MSWin32_5Cended_path($_)) {
3810 0 0       0 if (-d "$_/.") {
3811 0         0 return 1;
3812             }
3813             else {
3814 0         0 my $fh = gensym();
3815 0 0       0 if (_open_r($fh, $_)) {
3816 0         0 my $e = -e $fh;
3817 0         0 close $fh;
3818 0 0       0 return $e ? 1 : '';
3819             }
3820             }
3821             }
3822 0         0 return undef;
3823             }
3824              
3825             #
3826             # Big5-HKSCS file test -z $_
3827             #
3828             sub Ebig5hkscs::z_() {
3829              
3830 0 0   0 0 0 if (-e $_) {
    0          
3831 0 0       0 return -z _ ? 1 : '';
3832             }
3833             elsif (_MSWin32_5Cended_path($_)) {
3834 0 0       0 if (-d "$_/.") {
3835 0 0       0 return -z _ ? 1 : '';
3836             }
3837             else {
3838 0         0 my $fh = gensym();
3839 0 0       0 if (_open_r($fh, $_)) {
3840 0         0 my $z = -z $fh;
3841 0         0 close $fh;
3842 0 0       0 return $z ? 1 : '';
3843             }
3844             }
3845             }
3846 0         0 return undef;
3847             }
3848              
3849             #
3850             # Big5-HKSCS file test -s $_
3851             #
3852             sub Ebig5hkscs::s_() {
3853              
3854 0 0   0 0 0 if (-e $_) {
    0          
3855 0         0 return -s _;
3856             }
3857             elsif (_MSWin32_5Cended_path($_)) {
3858 0 0       0 if (-d "$_/.") {
3859 0         0 return -s _;
3860             }
3861             else {
3862 0         0 my $fh = gensym();
3863 0 0       0 if (_open_r($fh, $_)) {
3864 0         0 my $s = -s $fh;
3865 0         0 close $fh;
3866 0         0 return $s;
3867             }
3868             }
3869             }
3870 0         0 return undef;
3871             }
3872              
3873             #
3874             # Big5-HKSCS file test -f $_
3875             #
3876             sub Ebig5hkscs::f_() {
3877              
3878 0 0   0 0 0 if (-e $_) {
    0          
3879 0 0       0 return -f _ ? 1 : '';
3880             }
3881             elsif (_MSWin32_5Cended_path($_)) {
3882 0 0       0 if (-d "$_/.") {
3883 0         0 return '';
3884             }
3885             else {
3886 0         0 my $fh = gensym();
3887 0 0       0 if (_open_r($fh, $_)) {
3888 0         0 my $f = -f $fh;
3889 0         0 close $fh;
3890 0 0       0 return $f ? 1 : '';
3891             }
3892             }
3893             }
3894 0         0 return undef;
3895             }
3896              
3897             #
3898             # Big5-HKSCS file test -d $_
3899             #
3900             sub Ebig5hkscs::d_() {
3901              
3902 0 0   0 0 0 if (-e $_) {
    0          
3903 0 0       0 return -d _ ? 1 : '';
3904             }
3905             elsif (_MSWin32_5Cended_path($_)) {
3906 0 0       0 return -d "$_/." ? 1 : '';
3907             }
3908 0         0 return undef;
3909             }
3910              
3911             #
3912             # Big5-HKSCS file test -l $_
3913             #
3914             sub Ebig5hkscs::l_() {
3915              
3916 0 0   0 0 0 if (-e $_) {
    0          
3917 0 0       0 return -l _ ? 1 : '';
3918             }
3919             elsif (_MSWin32_5Cended_path($_)) {
3920 0 0       0 if (-d "$_/.") {
3921 0 0       0 return -l _ ? 1 : '';
3922             }
3923             else {
3924 0         0 my $fh = gensym();
3925 0 0       0 if (_open_r($fh, $_)) {
3926 0         0 my $l = -l $fh;
3927 0         0 close $fh;
3928 0 0       0 return $l ? 1 : '';
3929             }
3930             }
3931             }
3932 0         0 return undef;
3933             }
3934              
3935             #
3936             # Big5-HKSCS file test -p $_
3937             #
3938             sub Ebig5hkscs::p_() {
3939              
3940 0 0   0 0 0 if (-e $_) {
    0          
3941 0 0       0 return -p _ ? 1 : '';
3942             }
3943             elsif (_MSWin32_5Cended_path($_)) {
3944 0 0       0 if (-d "$_/.") {
3945 0 0       0 return -p _ ? 1 : '';
3946             }
3947             else {
3948 0         0 my $fh = gensym();
3949 0 0       0 if (_open_r($fh, $_)) {
3950 0         0 my $p = -p $fh;
3951 0         0 close $fh;
3952 0 0       0 return $p ? 1 : '';
3953             }
3954             }
3955             }
3956 0         0 return undef;
3957             }
3958              
3959             #
3960             # Big5-HKSCS file test -S $_
3961             #
3962             sub Ebig5hkscs::S_() {
3963              
3964 0 0   0 0 0 if (-e $_) {
    0          
3965 0 0       0 return -S _ ? 1 : '';
3966             }
3967             elsif (_MSWin32_5Cended_path($_)) {
3968 0 0       0 if (-d "$_/.") {
3969 0 0       0 return -S _ ? 1 : '';
3970             }
3971             else {
3972 0         0 my $fh = gensym();
3973 0 0       0 if (_open_r($fh, $_)) {
3974 0         0 my $S = -S $fh;
3975 0         0 close $fh;
3976 0 0       0 return $S ? 1 : '';
3977             }
3978             }
3979             }
3980 0         0 return undef;
3981             }
3982              
3983             #
3984             # Big5-HKSCS file test -b $_
3985             #
3986             sub Ebig5hkscs::b_() {
3987              
3988 0 0   0 0 0 if (-e $_) {
    0          
3989 0 0       0 return -b _ ? 1 : '';
3990             }
3991             elsif (_MSWin32_5Cended_path($_)) {
3992 0 0       0 if (-d "$_/.") {
3993 0 0       0 return -b _ ? 1 : '';
3994             }
3995             else {
3996 0         0 my $fh = gensym();
3997 0 0       0 if (_open_r($fh, $_)) {
3998 0         0 my $b = -b $fh;
3999 0         0 close $fh;
4000 0 0       0 return $b ? 1 : '';
4001             }
4002             }
4003             }
4004 0         0 return undef;
4005             }
4006              
4007             #
4008             # Big5-HKSCS file test -c $_
4009             #
4010             sub Ebig5hkscs::c_() {
4011              
4012 0 0   0 0 0 if (-e $_) {
    0          
4013 0 0       0 return -c _ ? 1 : '';
4014             }
4015             elsif (_MSWin32_5Cended_path($_)) {
4016 0 0       0 if (-d "$_/.") {
4017 0 0       0 return -c _ ? 1 : '';
4018             }
4019             else {
4020 0         0 my $fh = gensym();
4021 0 0       0 if (_open_r($fh, $_)) {
4022 0         0 my $c = -c $fh;
4023 0         0 close $fh;
4024 0 0       0 return $c ? 1 : '';
4025             }
4026             }
4027             }
4028 0         0 return undef;
4029             }
4030              
4031             #
4032             # Big5-HKSCS file test -u $_
4033             #
4034             sub Ebig5hkscs::u_() {
4035              
4036 0 0   0 0 0 if (-e $_) {
    0          
4037 0 0       0 return -u _ ? 1 : '';
4038             }
4039             elsif (_MSWin32_5Cended_path($_)) {
4040 0 0       0 if (-d "$_/.") {
4041 0 0       0 return -u _ ? 1 : '';
4042             }
4043             else {
4044 0         0 my $fh = gensym();
4045 0 0       0 if (_open_r($fh, $_)) {
4046 0         0 my $u = -u $fh;
4047 0         0 close $fh;
4048 0 0       0 return $u ? 1 : '';
4049             }
4050             }
4051             }
4052 0         0 return undef;
4053             }
4054              
4055             #
4056             # Big5-HKSCS file test -g $_
4057             #
4058             sub Ebig5hkscs::g_() {
4059              
4060 0 0   0 0 0 if (-e $_) {
    0          
4061 0 0       0 return -g _ ? 1 : '';
4062             }
4063             elsif (_MSWin32_5Cended_path($_)) {
4064 0 0       0 if (-d "$_/.") {
4065 0 0       0 return -g _ ? 1 : '';
4066             }
4067             else {
4068 0         0 my $fh = gensym();
4069 0 0       0 if (_open_r($fh, $_)) {
4070 0         0 my $g = -g $fh;
4071 0         0 close $fh;
4072 0 0       0 return $g ? 1 : '';
4073             }
4074             }
4075             }
4076 0         0 return undef;
4077             }
4078              
4079             #
4080             # Big5-HKSCS file test -k $_
4081             #
4082             sub Ebig5hkscs::k_() {
4083              
4084 0 0   0 0 0 if ($] =~ /^5\.008/oxms) {
4085 0 0       0 return wantarray ? ('',@_) : '';
4086             }
4087 0 0       0 return wantarray ? ($_,@_) : $_;
4088             }
4089              
4090             #
4091             # Big5-HKSCS file test -T $_
4092             #
4093             sub Ebig5hkscs::T_() {
4094              
4095 0     0 0 0 my $T = 1;
4096              
4097 0 0 0     0 if (-d $_ or -d "$_/.") {
4098 0         0 return undef;
4099             }
4100 0         0 my $fh = gensym();
4101 0 0       0 if (_open_r($fh, $_)) {
4102             }
4103             else {
4104 0         0 return undef;
4105             }
4106              
4107 0 0       0 if (sysread $fh, my $block, 512) {
4108 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4109 0         0 $T = '';
4110             }
4111             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4112 0         0 $T = '';
4113             }
4114             }
4115              
4116             # 0 byte or eof
4117             else {
4118 0         0 $T = 1;
4119             }
4120 0         0 my $dummy_for_underline_cache = -T $fh;
4121 0         0 close $fh;
4122              
4123 0         0 return $T;
4124             }
4125              
4126             #
4127             # Big5-HKSCS file test -B $_
4128             #
4129             sub Ebig5hkscs::B_() {
4130              
4131 0     0 0 0 my $B = '';
4132              
4133 0 0 0     0 if (-d $_ or -d "$_/.") {
4134 0         0 return undef;
4135             }
4136 0         0 my $fh = gensym();
4137 0 0       0 if (_open_r($fh, $_)) {
4138             }
4139             else {
4140 0         0 return undef;
4141             }
4142              
4143 0 0       0 if (sysread $fh, my $block, 512) {
4144 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4145 0         0 $B = 1;
4146             }
4147             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4148 0         0 $B = 1;
4149             }
4150             }
4151              
4152             # 0 byte or eof
4153             else {
4154 0         0 $B = 1;
4155             }
4156 0         0 my $dummy_for_underline_cache = -B $fh;
4157 0         0 close $fh;
4158              
4159 0         0 return $B;
4160             }
4161              
4162             #
4163             # Big5-HKSCS file test -M $_
4164             #
4165             sub Ebig5hkscs::M_() {
4166              
4167 0 0   0 0 0 if (-e $_) {
    0          
4168 0         0 return -M _;
4169             }
4170             elsif (_MSWin32_5Cended_path($_)) {
4171 0 0       0 if (-d "$_/.") {
4172 0         0 return -M _;
4173             }
4174             else {
4175 0         0 my $fh = gensym();
4176 0 0       0 if (_open_r($fh, $_)) {
4177 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4178 0         0 close $fh;
4179 0         0 my $M = ($^T - $mtime) / (24*60*60);
4180 0         0 return $M;
4181             }
4182             }
4183             }
4184 0         0 return undef;
4185             }
4186              
4187             #
4188             # Big5-HKSCS file test -A $_
4189             #
4190             sub Ebig5hkscs::A_() {
4191              
4192 0 0   0 0 0 if (-e $_) {
    0          
4193 0         0 return -A _;
4194             }
4195             elsif (_MSWin32_5Cended_path($_)) {
4196 0 0       0 if (-d "$_/.") {
4197 0         0 return -A _;
4198             }
4199             else {
4200 0         0 my $fh = gensym();
4201 0 0       0 if (_open_r($fh, $_)) {
4202 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4203 0         0 close $fh;
4204 0         0 my $A = ($^T - $atime) / (24*60*60);
4205 0         0 return $A;
4206             }
4207             }
4208             }
4209 0         0 return undef;
4210             }
4211              
4212             #
4213             # Big5-HKSCS file test -C $_
4214             #
4215             sub Ebig5hkscs::C_() {
4216              
4217 0 0   0 0 0 if (-e $_) {
    0          
4218 0         0 return -C _;
4219             }
4220             elsif (_MSWin32_5Cended_path($_)) {
4221 0 0       0 if (-d "$_/.") {
4222 0         0 return -C _;
4223             }
4224             else {
4225 0         0 my $fh = gensym();
4226 0 0       0 if (_open_r($fh, $_)) {
4227 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4228 0         0 close $fh;
4229 0         0 my $C = ($^T - $ctime) / (24*60*60);
4230 0         0 return $C;
4231             }
4232             }
4233             }
4234 0         0 return undef;
4235             }
4236              
4237             #
4238             # Big5-HKSCS path globbing (with parameter)
4239             #
4240             sub Ebig5hkscs::glob($) {
4241              
4242 0 0   0 0 0 if (wantarray) {
4243 0         0 my @glob = _DOS_like_glob(@_);
4244 0         0 for my $glob (@glob) {
4245 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4246             }
4247 0         0 return @glob;
4248             }
4249             else {
4250 0         0 my $glob = _DOS_like_glob(@_);
4251 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4252 0         0 return $glob;
4253             }
4254             }
4255              
4256             #
4257             # Big5-HKSCS path globbing (without parameter)
4258             #
4259             sub Ebig5hkscs::glob_() {
4260              
4261 0 0   0 0 0 if (wantarray) {
4262 0         0 my @glob = _DOS_like_glob();
4263 0         0 for my $glob (@glob) {
4264 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4265             }
4266 0         0 return @glob;
4267             }
4268             else {
4269 0         0 my $glob = _DOS_like_glob();
4270 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4271 0         0 return $glob;
4272             }
4273             }
4274              
4275             #
4276             # Big5-HKSCS path globbing via File::DosGlob 1.10
4277             #
4278             # Often I confuse "_dosglob" and "_doglob".
4279             # So, I renamed "_dosglob" to "_DOS_like_glob".
4280             #
4281             my %iter;
4282             my %entries;
4283             sub _DOS_like_glob {
4284              
4285             # context (keyed by second cxix argument provided by core)
4286 0     0   0 my($expr,$cxix) = @_;
4287              
4288             # glob without args defaults to $_
4289 0 0       0 $expr = $_ if not defined $expr;
4290              
4291             # represents the current user's home directory
4292             #
4293             # 7.3. Expanding Tildes in Filenames
4294             # in Chapter 7. File Access
4295             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4296             #
4297             # and File::HomeDir, File::HomeDir::Windows module
4298              
4299             # DOS-like system
4300 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4301 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
4302             { my_home_MSWin32() }oxmse;
4303             }
4304              
4305             # UNIX-like system
4306 0 0 0     0 else {
  0         0  
4307             $expr =~ s{ \A ~ ( (?:[^\x81-\xFE/]|[\x81-\xFE][\x00-\xFF])* ) }
4308             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
4309             }
4310 0 0       0  
4311 0 0       0 # assume global context if not provided one
4312             $cxix = '_G_' if not defined $cxix;
4313             $iter{$cxix} = 0 if not exists $iter{$cxix};
4314 0 0       0  
4315 0         0 # if we're just beginning, do it all first
4316             if ($iter{$cxix} == 0) {
4317             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
4318             }
4319 0 0       0  
4320 0         0 # chuck it all out, quick or slow
4321 0         0 if (wantarray) {
  0         0  
4322             delete $iter{$cxix};
4323             return @{delete $entries{$cxix}};
4324 0 0       0 }
  0         0  
4325 0         0 else {
  0         0  
4326             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
4327             return shift @{$entries{$cxix}};
4328             }
4329 0         0 else {
4330 0         0 # return undef for EOL
4331 0         0 delete $iter{$cxix};
4332             delete $entries{$cxix};
4333             return undef;
4334             }
4335             }
4336             }
4337              
4338             #
4339             # Big5-HKSCS path globbing subroutine
4340             #
4341 0     0   0 sub _do_glob {
4342 0         0  
4343 0         0 my($cond,@expr) = @_;
4344             my @glob = ();
4345             my $fix_drive_relative_paths = 0;
4346 0         0  
4347 0 0       0 OUTER:
4348 0 0       0 for my $expr (@expr) {
4349             next OUTER if not defined $expr;
4350 0         0 next OUTER if $expr eq '';
4351 0         0  
4352 0         0 my @matched = ();
4353 0         0 my @globdir = ();
4354 0         0 my $head = '.';
4355             my $pathsep = '/';
4356             my $tail;
4357 0 0       0  
4358 0         0 # if argument is within quotes strip em and do no globbing
4359 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
4360 0 0       0 $expr = $1;
4361 0         0 if ($cond eq 'd') {
4362             if (Ebig5hkscs::d $expr) {
4363             push @glob, $expr;
4364             }
4365 0 0       0 }
4366 0         0 else {
4367             if (Ebig5hkscs::e $expr) {
4368             push @glob, $expr;
4369 0         0 }
4370             }
4371             next OUTER;
4372             }
4373              
4374 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
4375 0 0       0 # to h:./*.pm to expand correctly
4376 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4377             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^\x81-\xFE/\\]|[\x81-\xFE][\x00-\xFF]) #$1./$2#oxms) {
4378             $fix_drive_relative_paths = 1;
4379             }
4380 0 0       0 }
4381 0 0       0  
4382 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
4383 0         0 if ($tail eq '') {
4384             push @glob, $expr;
4385 0 0       0 next OUTER;
4386 0 0       0 }
4387 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
4388 0         0 if (@globdir = _do_glob('d', $head)) {
4389             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
4390             next OUTER;
4391 0 0 0     0 }
4392 0         0 }
4393             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
4394 0         0 $head .= $pathsep;
4395             }
4396             $expr = $tail;
4397             }
4398 0 0       0  
4399 0 0       0 # If file component has no wildcards, we can avoid opendir
4400 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
4401             if ($head eq '.') {
4402 0 0 0     0 $head = '';
4403 0         0 }
4404             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4405 0         0 $head .= $pathsep;
4406 0 0       0 }
4407 0 0       0 $head .= $expr;
4408 0         0 if ($cond eq 'd') {
4409             if (Ebig5hkscs::d $head) {
4410             push @glob, $head;
4411             }
4412 0 0       0 }
4413 0         0 else {
4414             if (Ebig5hkscs::e $head) {
4415             push @glob, $head;
4416 0         0 }
4417             }
4418 0 0       0 next OUTER;
4419 0         0 }
4420 0         0 Ebig5hkscs::opendir(*DIR, $head) or next OUTER;
4421             my @leaf = readdir DIR;
4422 0 0       0 closedir DIR;
4423 0         0  
4424             if ($head eq '.') {
4425 0 0 0     0 $head = '';
4426 0         0 }
4427             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4428             $head .= $pathsep;
4429 0         0 }
4430 0         0  
4431 0         0 my $pattern = '';
4432             while ($expr =~ / \G ($q_char) /oxgc) {
4433             my $char = $1;
4434              
4435             # 6.9. Matching Shell Globs as Regular Expressions
4436             # in Chapter 6. Pattern Matching
4437             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4438 0 0       0 # (and so on)
    0          
    0          
4439 0         0  
4440             if ($char eq '*') {
4441             $pattern .= "(?:$your_char)*",
4442 0         0 }
4443             elsif ($char eq '?') {
4444             $pattern .= "(?:$your_char)?", # DOS style
4445             # $pattern .= "(?:$your_char)", # UNIX style
4446 0         0 }
4447             elsif ((my $fc = Ebig5hkscs::fc($char)) ne $char) {
4448             $pattern .= $fc;
4449 0         0 }
4450             else {
4451             $pattern .= quotemeta $char;
4452 0     0   0 }
  0         0  
4453             }
4454             my $matchsub = sub { Ebig5hkscs::fc($_[0]) =~ /\A $pattern \z/xms };
4455              
4456             # if ($@) {
4457             # print STDERR "$0: $@\n";
4458             # next OUTER;
4459             # }
4460 0         0  
4461 0 0 0     0 INNER:
4462 0         0 for my $leaf (@leaf) {
4463             if ($leaf eq '.' or $leaf eq '..') {
4464 0 0 0     0 next INNER;
4465 0         0 }
4466             if ($cond eq 'd' and not Ebig5hkscs::d "$head$leaf") {
4467             next INNER;
4468 0 0       0 }
4469 0         0  
4470 0         0 if (&$matchsub($leaf)) {
4471             push @matched, "$head$leaf";
4472             next INNER;
4473             }
4474              
4475             # [DOS compatibility special case]
4476 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
4477              
4478             if (Ebig5hkscs::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
4479             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
4480 0 0       0 Ebig5hkscs::index($pattern,'\\.') != -1 # pattern has a dot.
4481 0         0 ) {
4482 0         0 if (&$matchsub("$leaf.")) {
4483             push @matched, "$head$leaf";
4484             next INNER;
4485             }
4486 0 0       0 }
4487 0         0 }
4488             if (@matched) {
4489             push @glob, @matched;
4490 0 0       0 }
4491 0         0 }
4492 0         0 if ($fix_drive_relative_paths) {
4493             for my $glob (@glob) {
4494             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
4495 0         0 }
4496             }
4497             return @glob;
4498             }
4499              
4500             #
4501             # Big5-HKSCS parse line
4502             #
4503 0     0   0 sub _parse_line {
4504              
4505 0         0 my($line) = @_;
4506 0         0  
4507 0         0 $line .= ' ';
4508             my @piece = ();
4509             while ($line =~ /
4510             " ( (?>(?: [^\x81-\xFE"] |[\x81-\xFE][\x00-\xFF] )* ) ) " (?>\s+) |
4511             ( (?>(?: [^\x81-\xFE"\s]|[\x81-\xFE][\x00-\xFF] )* ) ) (?>\s+)
4512 0 0       0 /oxmsg
4513             ) {
4514 0         0 push @piece, defined($1) ? $1 : $2;
4515             }
4516             return @piece;
4517             }
4518              
4519             #
4520             # Big5-HKSCS parse path
4521             #
4522 0     0   0 sub _parse_path {
4523              
4524 0         0 my($path,$pathsep) = @_;
4525 0         0  
4526 0         0 $path .= '/';
4527             my @subpath = ();
4528             while ($path =~ /
4529             ((?: [^\x81-\xFE\/\\]|[\x81-\xFE][\x00-\xFF] )+?) [\/\\]
4530 0         0 /oxmsg
4531             ) {
4532             push @subpath, $1;
4533 0         0 }
4534 0         0  
4535 0         0 my $tail = pop @subpath;
4536             my $head = join $pathsep, @subpath;
4537             return $head, $tail;
4538             }
4539              
4540             #
4541             # via File::HomeDir::Windows 1.00
4542             #
4543             sub my_home_MSWin32 {
4544              
4545             # A lot of unix people and unix-derived tools rely on
4546 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
4547 0         0 # so that they can replace raw HOME calls with File::HomeDir.
4548             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
4549             return $ENV{'HOME'};
4550             }
4551              
4552 0         0 # Do we have a user profile?
4553             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
4554             return $ENV{'USERPROFILE'};
4555             }
4556              
4557 0         0 # Some Windows use something like $ENV{'HOME'}
4558             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
4559             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
4560 0         0 }
4561              
4562             return undef;
4563             }
4564              
4565             #
4566             # via File::HomeDir::Unix 1.00
4567 0     0 0 0 #
4568             sub my_home {
4569 0 0 0     0 my $home;
    0 0        
4570 0         0  
4571             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
4572             $home = $ENV{'HOME'};
4573             }
4574              
4575             # This is from the original code, but I'm guessing
4576 0         0 # it means "login directory" and exists on some Unixes.
4577             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
4578             $home = $ENV{'LOGDIR'};
4579             }
4580              
4581             ### More-desperate methods
4582              
4583 0         0 # Light desperation on any (Unixish) platform
4584             else {
4585             $home = CORE::eval q{ (getpwuid($<))[7] };
4586             }
4587              
4588 0 0 0     0 # On Unix in general, a non-existant home means "no home"
4589 0         0 # For example, "nobody"-like users might use /nonexistant
4590             if (defined $home and ! Ebig5hkscs::d($home)) {
4591 0         0 $home = undef;
4592             }
4593             return $home;
4594             }
4595              
4596             #
4597             # Big5-HKSCS file lstat (with parameter)
4598             #
4599 0 0   0 0 0 sub Ebig5hkscs::lstat(*) {
4600              
4601 0 0       0 local $_ = shift if @_;
    0          
4602 0         0  
4603             if (-e $_) {
4604             return CORE::lstat _;
4605             }
4606             elsif (_MSWin32_5Cended_path($_)) {
4607              
4608             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Ebig5hkscs::lstat()
4609             # on Windows opens the file for the path which has 5c at end.
4610 0         0 # (and so on)
4611 0 0       0  
4612 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4613 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4614 0         0 if (wantarray) {
4615 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4616             close MUST_BE_BAREWORD_AT_HERE;
4617             return @stat;
4618 0         0 }
4619 0         0 else {
4620 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4621             close MUST_BE_BAREWORD_AT_HERE;
4622             return $stat;
4623             }
4624 0 0       0 }
4625             }
4626             return wantarray ? () : undef;
4627             }
4628              
4629             #
4630             # Big5-HKSCS file lstat (without parameter)
4631             #
4632 0 0   0 0 0 sub Ebig5hkscs::lstat_() {
    0          
4633 0         0  
4634             if (-e $_) {
4635             return CORE::lstat _;
4636 0         0 }
4637 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4638 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4639 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4640 0         0 if (wantarray) {
4641 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4642             close MUST_BE_BAREWORD_AT_HERE;
4643             return @stat;
4644 0         0 }
4645 0         0 else {
4646 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4647             close MUST_BE_BAREWORD_AT_HERE;
4648             return $stat;
4649             }
4650 0 0       0 }
4651             }
4652             return wantarray ? () : undef;
4653             }
4654              
4655             #
4656             # Big5-HKSCS path opendir
4657             #
4658 0     0 0 0 sub Ebig5hkscs::opendir(*$) {
4659 0 0       0  
    0          
4660 0         0 my $dh = qualify_to_ref $_[0];
4661             if (CORE::opendir $dh, $_[1]) {
4662             return 1;
4663 0 0       0 }
4664 0         0 elsif (_MSWin32_5Cended_path($_[1])) {
4665             if (CORE::opendir $dh, "$_[1]/.") {
4666             return 1;
4667 0         0 }
4668             }
4669             return undef;
4670             }
4671              
4672             #
4673             # Big5-HKSCS file stat (with parameter)
4674             #
4675 0 50   384 0 0 sub Ebig5hkscs::stat(*) {
4676              
4677 384         3306 local $_ = shift if @_;
4678 384 50       2715  
    50          
    0          
4679 384         29240 my $fh = qualify_to_ref $_;
4680             if (defined fileno $fh) {
4681             return CORE::stat $fh;
4682 0         0 }
4683             elsif (-e $_) {
4684             return CORE::stat _;
4685             }
4686             elsif (_MSWin32_5Cended_path($_)) {
4687              
4688             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Ebig5hkscs::stat()
4689             # on Windows opens the file for the path which has 5c at end.
4690 384         2889 # (and so on)
4691 0 0       0  
4692 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4693 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4694 0         0 if (wantarray) {
4695 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4696             close MUST_BE_BAREWORD_AT_HERE;
4697             return @stat;
4698 0         0 }
4699 0         0 else {
4700 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4701             close MUST_BE_BAREWORD_AT_HERE;
4702             return $stat;
4703             }
4704 0 0       0 }
4705             }
4706             return wantarray ? () : undef;
4707             }
4708              
4709             #
4710             # Big5-HKSCS file stat (without parameter)
4711             #
4712 0     0 0 0 sub Ebig5hkscs::stat_() {
4713 0 0       0  
    0          
    0          
4714 0         0 my $fh = qualify_to_ref $_;
4715             if (defined fileno $fh) {
4716             return CORE::stat $fh;
4717 0         0 }
4718             elsif (-e $_) {
4719             return CORE::stat _;
4720 0         0 }
4721 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4722 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4723 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4724 0         0 if (wantarray) {
4725 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4726             close MUST_BE_BAREWORD_AT_HERE;
4727             return @stat;
4728 0         0 }
4729 0         0 else {
4730 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4731             close MUST_BE_BAREWORD_AT_HERE;
4732             return $stat;
4733             }
4734 0 0       0 }
4735             }
4736             return wantarray ? () : undef;
4737             }
4738              
4739             #
4740             # Big5-HKSCS path unlink
4741             #
4742 0 0   0 0 0 sub Ebig5hkscs::unlink(@) {
4743              
4744 0         0 local @_ = ($_) unless @_;
4745 0         0  
4746 0 0       0 my $unlink = 0;
    0          
    0          
4747 0         0 for (@_) {
4748             if (CORE::unlink) {
4749             $unlink++;
4750             }
4751             elsif (Ebig5hkscs::d($_)) {
4752 0         0 }
4753 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
  0         0  
4754 0 0       0 my @char = /\G (?>$q_char) /oxmsg;
4755 0         0 my $file = join '', map {{'/' => '\\'}->{$_} || $_} @char;
4756             if ($file =~ / \A (?:$q_char)*? [ ] /oxms) {
4757 0         0 $file = qq{"$file"};
4758 0 0       0 }
4759 0         0 my $fh = gensym();
4760             if (_open_r($fh, $_)) {
4761             close $fh;
4762 0 0 0     0  
    0          
4763 0         0 # cmd.exe on Windows NT, Windows 2000, Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
4764             if ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
4765             CORE::system 'DEL', '/F', $file, '2>NUL';
4766             }
4767              
4768 0         0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
4769             elsif (qx{ver} =~ /\b(?:Windows 2000)\b/oms) {
4770             CORE::system 'DEL', '/F', $file, '2>NUL';
4771             }
4772              
4773             # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
4774 0         0 # command.com can not "2>NUL"
4775 0         0 else {
4776             CORE::system 'ATTRIB', '-R', $file; # clears Read-only file attribute
4777             CORE::system 'DEL', $file;
4778 0 0       0 }
4779 0         0  
4780             if (_open_r($fh, $_)) {
4781             close $fh;
4782 0         0 }
4783             else {
4784             $unlink++;
4785             }
4786             }
4787 0         0 }
4788             }
4789             return $unlink;
4790             }
4791              
4792             #
4793             # Big5-HKSCS chdir
4794             #
4795 0 0   0 0 0 sub Ebig5hkscs::chdir(;$) {
4796 0         0  
4797             if (@_ == 0) {
4798             return CORE::chdir;
4799 0         0 }
4800              
4801 0 0       0 my($dir) = @_;
4802 0 0       0  
4803 0         0 if (_MSWin32_5Cended_path($dir)) {
4804             if (not Ebig5hkscs::d $dir) {
4805             return 0;
4806 0 0 0     0 }
    0          
4807 0         0  
4808             if ($] =~ /^5\.005/oxms) {
4809             return CORE::chdir $dir;
4810 0         0 }
4811 0         0 elsif (($] =~ /^(?:5\.006|5\.008000)/oxms) and ($^O eq 'MSWin32')) {
4812             local $@;
4813             my $chdir = CORE::eval q{
4814             CORE::require 'jacode.pl';
4815              
4816             # P.676 ${^WIDE_SYSTEM_CALLS}
4817             # in Chapter 28: Special Names
4818             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4819              
4820             # P.790 ${^WIDE_SYSTEM_CALLS}
4821             # in Chapter 25: Special Names
4822             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4823              
4824             local ${^WIDE_SYSTEM_CALLS} = 1;
4825 0 0       0 return CORE::chdir jcode::utf8($dir,'sjis');
4826 0         0 };
4827             if (not $@) {
4828             return $chdir;
4829             }
4830             }
4831              
4832             # old idea (Win32 module required)
4833             elsif (0) {
4834             local $@;
4835             my $shortdir = '';
4836             my $chdir = CORE::eval q{
4837             use Win32;
4838             $shortdir = Win32::GetShortPathName($dir);
4839             if ($shortdir ne $dir) {
4840             return CORE::chdir $shortdir;
4841             }
4842             else {
4843             return 0;
4844             }
4845             };
4846             if ($@) {
4847             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4848             while ($char[-1] eq "\x5C") {
4849             pop @char;
4850             }
4851             $dir = join '', @char;
4852             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path), Win32.pm module may help you";
4853             }
4854             elsif ($shortdir eq $dir) {
4855             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4856             while ($char[-1] eq "\x5C") {
4857             pop @char;
4858             }
4859             $dir = join '', @char;
4860             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path)";
4861             }
4862             return $chdir;
4863             }
4864 0         0  
4865             # rejected idea ...
4866             elsif (0) {
4867              
4868             # MSDN SetCurrentDirectory function
4869             # http://msdn.microsoft.com/ja-jp/library/windows/desktop/aa365530(v=vs.85).aspx
4870             #
4871             # Data Execution Prevention (DEP)
4872             # http://vlaurie.com/computers2/Articles/dep.htm
4873             #
4874             # Learning x86 assembler with Perl -- Shibuya.pm#11
4875             # http://developer.cybozu.co.jp/takesako/2009/06/perl-x86-shibuy.html
4876             #
4877             # Introduction to Win32::API programming in Perl
4878             # http://d.hatena.ne.jp/TAKESAKO/20090324/1237879559
4879             #
4880             # DynaLoader - Dynamically load C libraries into Perl code
4881             # http://perldoc.perl.org/DynaLoader.html
4882             #
4883             # Basic knowledge of DynaLoader
4884             # http://blog.64p.org/entry/20090313/1236934042
4885              
4886             if (($] =~ /^5\.006/oxms) and
4887             ($^O eq 'MSWin32') and
4888             ($ENV{'PROCESSOR_ARCHITECTURE'} eq 'x86') and
4889             CORE::eval(q{CORE::require 'Dyna'.'Loader'})
4890             ) {
4891             my $x86 = join('',
4892              
4893             # PUSH Iv
4894             "\x68", pack('P', "$dir\\\0"),
4895              
4896             # MOV eAX, Iv
4897             "\xb8", pack('L',
4898             *{'Dyna'.'Loader::dl_find_symbol'}{'CODE'}->(
4899             *{'Dyna'.'Loader::dl_load_file'}{'CODE'}->("$ENV{'SystemRoot'}\\system32\\kernel32.dll"),
4900             'SetCurrentDirectoryA'
4901             )
4902             ),
4903              
4904             # CALL eAX
4905             "\xff\xd0",
4906              
4907             # RETN
4908             "\xc3",
4909             );
4910             *{'Dyna'.'Loader::dl_install_xsub'}{'CODE'}->('_SetCurrentDirectoryA', unpack('L', pack 'P', $x86));
4911             _SetCurrentDirectoryA();
4912             chomp(my $chdir = qx{chdir});
4913             if (Ebig5hkscs::fc($chdir) eq Ebig5hkscs::fc($dir)) {
4914             return 1;
4915             }
4916             else {
4917             return 0;
4918             }
4919             }
4920             }
4921              
4922             # COMMAND.COM's unhelpful tips:
4923             # Displays a list of files and subdirectories in a directory.
4924             # http://www.lagmonster.org/docs/DOS7/z-dir.html
4925             #
4926             # Syntax:
4927             #
4928             # DIR [drive:] [path] [filename] [/Switches]
4929             #
4930             # /Z Long file names are not displayed in the file listing
4931             #
4932             # Limitations
4933             # The undocumented /Z switch (no long names) would appear to
4934             # have been not fully developed and has a couple of problems:
4935             #
4936             # 1. It will only work if:
4937             # There is no path specified (ie. for the current directory in
4938             # the current drive)
4939             # The path is specified as the root directory of any drive
4940             # (eg. C:\, D:\, etc.)
4941             # The path is specified as the current directory of any drive
4942             # by using the drive letter only (eg. C:, D:, etc.)
4943             # The path is specified as the parent directory using the ..
4944             # notation (eg. DIR .. /Z)
4945             # Any other syntax results in a "File Not Found" error message.
4946             #
4947             # 2. The /Z switch is compatable with the /S switch to show
4948             # subdirectories (as long as the above rules are followed) and
4949             # all the files are shown with short names only. The
4950             # subdirectories are also shown with short names only. However,
4951             # the header for each subdirectory after the first level gives
4952             # the subdirectory's long name.
4953             #
4954             # 3. The /Z switch is also compatable with the /B switch to give
4955             # a simple list of files with short names only. When used with
4956             # the /S switch as well, all files are listed with their full
4957             # paths. The file names themselves are all in short form, and
4958             # the path of those files in the current directory are in short
4959             # form, but the paths of any files in subdirectories are in
4960 0         0 # long filename form.
4961 0         0  
4962 0         0 my $shortdir = '';
4963 0         0 my $i = 0;
4964 0         0 my @subdir = ();
4965 0 0 0     0 while ($dir =~ / \G ($q_char) /oxgc) {
4966 0         0 my $char = $1;
4967 0         0 if (($char eq '\\') or ($char eq '/')) {
4968 0         0 $i++;
4969             $subdir[$i] = $char;
4970             $i++;
4971 0         0 }
4972             else {
4973             $subdir[$i] .= $char;
4974 0 0 0     0 }
4975 0         0 }
4976             if (($subdir[-1] eq '\\') or ($subdir[-1] eq '/')) {
4977             pop @subdir;
4978             }
4979              
4980             # P.504 PERL5SHELL (Microsoft ports only)
4981             # in Chapter 19: The Command-Line Interface
4982             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4983              
4984             # P.597 PERL5SHELL (Microsoft ports only)
4985             # in Chapter 17: The Command-Line Interface
4986             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4987              
4988 0 0 0     0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
    0          
4989 0         0 # cmd.exe on Windows NT, Windows 2000
4990 0         0 if (qx{ver} =~ /\b(?:Windows NT|Windows 2000)\b/oms) {
  0         0  
4991 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
4992             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
4993             if (Ebig5hkscs::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Ebig5hkscs::fc($subdir[-1])) {
4994 0         0  
4995 0         0 # short file name (8dot3name) here-----vv
4996 0         0 my $shortleafdir = CORE::substr $dirx, 39, 8+1+3;
4997 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
4998             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
4999             last;
5000             }
5001             }
5002             }
5003              
5004             # an idea (not so portable, only Windows 2000 or later)
5005             elsif (0) {
5006             chomp($shortdir = qx{for %I in ("$dir") do \@echo %~sI 2>NUL});
5007             }
5008              
5009 0         0 # cmd.exe on Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
5010 0         0 elsif ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
  0         0  
5011 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5012             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5013             if (Ebig5hkscs::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Ebig5hkscs::fc($subdir[-1])) {
5014 0         0  
5015 0         0 # short file name (8dot3name) here-----vv
5016 0         0 my $shortleafdir = CORE::substr $dirx, 36, 8+1+3;
5017 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5018             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5019             last;
5020             }
5021             }
5022             }
5023              
5024 0         0 # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
5025 0         0 else {
  0         0  
5026 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad "$dir*"});
5027             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5028             if (Ebig5hkscs::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Ebig5hkscs::fc($subdir[-1])) {
5029 0         0  
5030 0         0 # short file name (8dot3name) here-----v
5031 0         0 my $shortleafdir = CORE::substr $dirx, 0, 8+1+3;
5032 0         0 CORE::substr($shortleafdir,8,1) = '.';
5033 0         0 $shortleafdir =~ s/ \. [ ]+ \z//oxms;
5034             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5035             last;
5036             }
5037             }
5038 0 0       0 }
    0          
5039 0         0  
5040             if ($shortdir eq '') {
5041             return 0;
5042 0         0 }
5043             elsif (Ebig5hkscs::fc($shortdir) eq Ebig5hkscs::fc($dir)) {
5044 0         0 return 0;
5045             }
5046             return CORE::chdir $shortdir;
5047 0         0 }
5048             else {
5049             return CORE::chdir $dir;
5050             }
5051             }
5052              
5053             #
5054             # Big5-HKSCS chr(0x5C) ended path on MSWin32
5055             #
5056 0 50 33 768   0 sub _MSWin32_5Cended_path {
5057 768 50       5374  
5058 768         4289 if ((@_ >= 1) and ($_[0] ne '')) {
5059 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
5060 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5061             if ($char[-1] =~ / \x5C \z/oxms) {
5062             return 1;
5063             }
5064 0         0 }
5065             }
5066             return undef;
5067             }
5068              
5069             #
5070             # do Big5-HKSCS file
5071             #
5072 768     0 0 2104 sub Ebig5hkscs::do($) {
5073              
5074 0         0 my($filename) = @_;
5075              
5076             my $realfilename;
5077             my $result;
5078 0         0 ITER_DO:
  0         0  
5079 0 0       0 {
5080 0         0 for my $prefix (@INC) {
5081             if ($^O eq 'MacOS') {
5082             $realfilename = "$prefix$filename";
5083 0         0 }
5084             else {
5085             $realfilename = "$prefix/$filename";
5086 0 0       0 }
5087              
5088 0         0 if (Ebig5hkscs::f($realfilename)) {
5089              
5090 0 0       0 my $script = '';
5091 0         0  
5092 0         0 if (Ebig5hkscs::e("$realfilename.e")) {
5093 0         0 my $e_mtime = (Ebig5hkscs::stat("$realfilename.e"))[9];
5094 0 0 0     0 my $mtime = (Ebig5hkscs::stat($realfilename))[9];
5095 0         0 my $module_mtime = (Ebig5hkscs::stat(__FILE__))[9];
5096             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5097             Ebig5hkscs::unlink "$realfilename.e";
5098             }
5099 0 0       0 }
5100 0         0  
5101 0 0       0 if (Ebig5hkscs::e("$realfilename.e")) {
5102 0 0       0 my $fh = gensym();
    0          
5103 0         0 if (_open_r($fh, "$realfilename.e")) {
5104             if ($^O eq 'MacOS') {
5105             CORE::eval q{
5106             CORE::require Mac::Files;
5107             Mac::Files::FSpSetFLock("$realfilename.e");
5108             };
5109             }
5110             elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5111              
5112             # P.419 File Locking
5113             # in Chapter 16: Interprocess Communication
5114             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5115              
5116             # P.524 File Locking
5117             # in Chapter 15: Interprocess Communication
5118             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5119              
5120 0         0 # (and so on)
5121 0 0       0  
5122 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5123             if ($@) {
5124             carp "Can't immediately read-lock the file: $realfilename.e";
5125             }
5126 0         0 }
5127             else {
5128 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5129 0         0 }
5130 0 0       0 local $/ = undef; # slurp mode
5131 0         0 $script = <$fh>;
5132             if ($^O eq 'MacOS') {
5133             CORE::eval q{
5134             CORE::require Mac::Files;
5135             Mac::Files::FSpRstFLock("$realfilename.e");
5136 0         0 };
5137             }
5138             close $fh;
5139             }
5140 0         0 }
5141 0 0       0 else {
5142 0 0       0 my $fh = gensym();
    0          
5143 0         0 if (_open_r($fh, $realfilename)) {
5144             if ($^O eq 'MacOS') {
5145             CORE::eval q{
5146             CORE::require Mac::Files;
5147             Mac::Files::FSpSetFLock($realfilename);
5148             };
5149 0         0 }
5150 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5151 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5152             if ($@) {
5153             carp "Can't immediately read-lock the file: $realfilename";
5154             }
5155 0         0 }
5156             else {
5157 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5158 0         0 }
5159 0 0       0 local $/ = undef; # slurp mode
5160 0         0 $script = <$fh>;
5161             if ($^O eq 'MacOS') {
5162             CORE::eval q{
5163             CORE::require Mac::Files;
5164             Mac::Files::FSpRstFLock($realfilename);
5165 0         0 };
5166             }
5167             close $fh;
5168 0 0       0 }
5169 0         0  
5170 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5171 0         0 CORE::require Big5HKSCS;
5172 0 0       0 $script = Big5HKSCS::escape_script($script);
5173 0 0       0 my $fh = gensym();
    0          
5174 0         0 open($fh, ">$realfilename.e") or die __FILE__, ": Can't write open file: $realfilename.e\n";
5175             if ($^O eq 'MacOS') {
5176             CORE::eval q{
5177             CORE::require Mac::Files;
5178             Mac::Files::FSpSetFLock("$realfilename.e");
5179             };
5180 0         0 }
5181 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5182 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5183             if ($@) {
5184             carp "Can't immediately write-lock the file: $realfilename.e";
5185             }
5186 0         0 }
5187             else {
5188 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5189 0 0       0 }
5190 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5191 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5192 0         0 print {$fh} $script;
5193             if ($^O eq 'MacOS') {
5194             CORE::eval q{
5195             CORE::require Mac::Files;
5196             Mac::Files::FSpRstFLock("$realfilename.e");
5197 0         0 };
5198             }
5199             close $fh;
5200             }
5201             }
5202 389     389   12925  
  389         2903  
  389         365333  
  0         0  
5203 0         0 {
5204             no strict;
5205 0         0 $result = scalar CORE::eval $script;
5206             }
5207             last ITER_DO;
5208             }
5209             }
5210 0 0       0 }
    0          
5211 0         0  
5212 0         0 if ($@) {
5213             $INC{$filename} = undef;
5214             return undef;
5215 0         0 }
5216             elsif (not $result) {
5217             return undef;
5218 0         0 }
5219 0         0 else {
5220             $INC{$filename} = $realfilename;
5221             return $result;
5222             }
5223             }
5224              
5225             #
5226             # require Big5-HKSCS file
5227             #
5228              
5229             # require
5230             # in Chapter 3: Functions
5231             # of ISBN 1-56592-149-6 Programming Perl, Second Edition.
5232             #
5233             # sub require {
5234             # my($filename) = @_;
5235             # return 1 if $INC{$filename};
5236             # my($realfilename, $result);
5237             # ITER: {
5238             # foreach $prefix (@INC) {
5239             # $realfilename = "$prefix/$filename";
5240             # if (-f $realfilename) {
5241             # $result = CORE::eval `cat $realfilename`;
5242             # last ITER;
5243             # }
5244             # }
5245             # die "Can't find $filename in \@INC";
5246             # }
5247             # die $@ if $@;
5248             # die "$filename did not return true value" unless $result;
5249             # $INC{$filename} = $realfilename;
5250             # return $result;
5251             # }
5252              
5253             # require
5254             # in Chapter 9: perlfunc: Perl builtin functions
5255             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
5256             #
5257             # sub require {
5258             # my($filename) = @_;
5259             # if (exists $INC{$filename}) {
5260             # return 1 if $INC{$filename};
5261             # die "Compilation failed in require";
5262             # }
5263             # my($realfilename, $result);
5264             # ITER: {
5265             # foreach $prefix (@INC) {
5266             # $realfilename = "$prefix/$filename";
5267             # if (-f $realfilename) {
5268             # $INC{$filename} = $realfilename;
5269             # $result = do $realfilename;
5270             # last ITER;
5271             # }
5272             # }
5273             # die "Can't find $filename in \@INC";
5274             # }
5275             # if ($@) {
5276             # $INC{$filename} = undef;
5277             # die $@;
5278             # }
5279             # elsif (!$result) {
5280             # delete $INC{$filename};
5281             # die "$filename did not return true value";
5282             # }
5283             # else {
5284             # return $result;
5285             # }
5286             # }
5287              
5288 0 0   0 0 0 sub Ebig5hkscs::require(;$) {
5289              
5290 0 0       0 local $_ = shift if @_;
5291 0 0       0  
5292 0         0 if (exists $INC{$_}) {
5293             return 1 if $INC{$_};
5294             croak "Compilation failed in require: $_";
5295             }
5296              
5297             # jcode.pl
5298             # ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
5299              
5300             # jacode.pl
5301 0 0       0 # http://search.cpan.org/dist/jacode/
5302 0         0  
5303             if (/ \b (?: jcode\.pl | jacode(?>[0-9]*)\.pl ) \z /oxms) {
5304             return CORE::require($_);
5305 0         0 }
5306              
5307             my $realfilename;
5308             my $result;
5309 0         0 ITER_REQUIRE:
  0         0  
5310 0 0       0 {
5311 0         0 for my $prefix (@INC) {
5312             if ($^O eq 'MacOS') {
5313             $realfilename = "$prefix$_";
5314 0         0 }
5315             else {
5316             $realfilename = "$prefix/$_";
5317 0 0       0 }
5318 0         0  
5319             if (Ebig5hkscs::f($realfilename)) {
5320 0         0 $INC{$_} = $realfilename;
5321              
5322 0 0       0 my $script = '';
5323 0         0  
5324 0         0 if (Ebig5hkscs::e("$realfilename.e")) {
5325 0         0 my $e_mtime = (Ebig5hkscs::stat("$realfilename.e"))[9];
5326 0 0 0     0 my $mtime = (Ebig5hkscs::stat($realfilename))[9];
5327 0         0 my $module_mtime = (Ebig5hkscs::stat(__FILE__))[9];
5328             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5329             Ebig5hkscs::unlink "$realfilename.e";
5330             }
5331 0 0       0 }
5332 0         0  
5333 0 0       0 if (Ebig5hkscs::e("$realfilename.e")) {
5334 0 0       0 my $fh = gensym();
    0          
5335 0         0 _open_r($fh, "$realfilename.e") or croak "Can't open file: $realfilename.e";
5336             if ($^O eq 'MacOS') {
5337             CORE::eval q{
5338             CORE::require Mac::Files;
5339             Mac::Files::FSpSetFLock("$realfilename.e");
5340             };
5341 0         0 }
5342 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5343 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5344             if ($@) {
5345             carp "Can't immediately read-lock the file: $realfilename.e";
5346             }
5347 0         0 }
5348             else {
5349 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5350 0         0 }
5351 0 0       0 local $/ = undef; # slurp mode
5352 0         0 $script = <$fh>;
5353             if ($^O eq 'MacOS') {
5354             CORE::eval q{
5355             CORE::require Mac::Files;
5356             Mac::Files::FSpRstFLock("$realfilename.e");
5357 0 0       0 };
5358             }
5359             close($fh) or croak "Can't close file: $realfilename";
5360 0         0 }
5361 0 0       0 else {
5362 0 0       0 my $fh = gensym();
    0          
5363 0         0 _open_r($fh, $realfilename) or croak "Can't open file: $realfilename";
5364             if ($^O eq 'MacOS') {
5365             CORE::eval q{
5366             CORE::require Mac::Files;
5367             Mac::Files::FSpSetFLock($realfilename);
5368             };
5369 0         0 }
5370 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5371 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5372             if ($@) {
5373             carp "Can't immediately read-lock the file: $realfilename";
5374             }
5375 0         0 }
5376             else {
5377 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5378 0         0 }
5379 0 0       0 local $/ = undef; # slurp mode
5380 0         0 $script = <$fh>;
5381             if ($^O eq 'MacOS') {
5382             CORE::eval q{
5383             CORE::require Mac::Files;
5384             Mac::Files::FSpRstFLock($realfilename);
5385 0 0       0 };
5386             }
5387 0 0       0 close($fh) or croak "Can't close file: $realfilename";
5388 0         0  
5389 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5390 0         0 CORE::require Big5HKSCS;
5391 0 0       0 $script = Big5HKSCS::escape_script($script);
5392 0 0       0 my $fh = gensym();
    0          
5393 0         0 open($fh, ">$realfilename.e") or croak "Can't write open file: $realfilename.e";
5394             if ($^O eq 'MacOS') {
5395             CORE::eval q{
5396             CORE::require Mac::Files;
5397             Mac::Files::FSpSetFLock("$realfilename.e");
5398             };
5399 0         0 }
5400 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5401 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5402             if ($@) {
5403             carp "Can't immediately write-lock the file: $realfilename.e";
5404             }
5405 0         0 }
5406             else {
5407 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5408 0 0       0 }
5409 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5410 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5411 0         0 print {$fh} $script;
5412             if ($^O eq 'MacOS') {
5413             CORE::eval q{
5414             CORE::require Mac::Files;
5415             Mac::Files::FSpRstFLock("$realfilename.e");
5416 0 0       0 };
5417             }
5418             close($fh) or croak "Can't close file: $realfilename";
5419             }
5420             }
5421 389     389   4322  
  389         2231  
  389         392638  
  0         0  
5422 0         0 {
5423             no strict;
5424 0         0 $result = scalar CORE::eval $script;
5425             }
5426             last ITER_REQUIRE;
5427 0         0 }
5428             }
5429             croak "Can't find $_ in \@INC";
5430 0 0       0 }
    0          
5431 0         0  
5432 0         0 if ($@) {
5433             $INC{$_} = undef;
5434             croak $@;
5435 0         0 }
5436 0         0 elsif (not $result) {
5437             delete $INC{$_};
5438             croak "$_ did not return true value";
5439 0         0 }
5440             else {
5441             return $result;
5442             }
5443             }
5444              
5445             #
5446             # Big5-HKSCS telldir avoid warning
5447             #
5448 0     768 0 0 sub Ebig5hkscs::telldir(*) {
5449              
5450 768         2424 local $^W = 0;
5451              
5452             return CORE::telldir $_[0];
5453             }
5454              
5455             #
5456             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
5457 768 0   0 0 34023 #
5458 0 0 0     0 sub Ebig5hkscs::PREMATCH {
5459 0         0 if (defined($&)) {
5460             if (defined($1) and (CORE::substr($&,-CORE::length($1),CORE::length($1)) eq $1)) {
5461             return CORE::substr($&,0,CORE::length($&)-CORE::length($1));
5462 0         0 }
5463             else {
5464             croak 'Use of "$`", $PREMATCH, and ${^PREMATCH} need to /( capture all )/ in regexp';
5465             }
5466 0         0 }
5467             else {
5468 0         0 return '';
5469             }
5470             return $`;
5471             }
5472              
5473             #
5474             # ${^MATCH}, $MATCH, $& the string that matched
5475 0 0   0 0 0 #
5476 0 0       0 sub Ebig5hkscs::MATCH {
5477 0         0 if (defined($&)) {
5478             if (defined($1)) {
5479             return $1;
5480 0         0 }
5481             else {
5482             croak 'Use of "$&", $MATCH, and ${^MATCH} need to /( capture all )/ in regexp';
5483             }
5484 0         0 }
5485             else {
5486 0         0 return '';
5487             }
5488             return $&;
5489             }
5490              
5491             #
5492             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
5493 0     0 0 0 #
5494             sub Ebig5hkscs::POSTMATCH {
5495             return $';
5496             }
5497              
5498             #
5499             # Big5-HKSCS character to order (with parameter)
5500             #
5501 0 0   0 1 0 sub Big5HKSCS::ord(;$) {
5502              
5503 0 0       0 local $_ = shift if @_;
5504 0         0  
5505 0         0 if (/\A ($q_char) /oxms) {
5506 0         0 my @ord = unpack 'C*', $1;
5507 0         0 my $ord = 0;
5508             while (my $o = shift @ord) {
5509 0         0 $ord = $ord * 0x100 + $o;
5510             }
5511             return $ord;
5512 0         0 }
5513             else {
5514             return CORE::ord $_;
5515             }
5516             }
5517              
5518             #
5519             # Big5-HKSCS character to order (without parameter)
5520             #
5521 0 0   0 0 0 sub Big5HKSCS::ord_() {
5522 0         0  
5523 0         0 if (/\A ($q_char) /oxms) {
5524 0         0 my @ord = unpack 'C*', $1;
5525 0         0 my $ord = 0;
5526             while (my $o = shift @ord) {
5527 0         0 $ord = $ord * 0x100 + $o;
5528             }
5529             return $ord;
5530 0         0 }
5531             else {
5532             return CORE::ord $_;
5533             }
5534             }
5535              
5536             #
5537             # Big5-HKSCS reverse
5538             #
5539 0 0   0 0 0 sub Big5HKSCS::reverse(@) {
5540 0         0  
5541             if (wantarray) {
5542             return CORE::reverse @_;
5543             }
5544             else {
5545              
5546             # One of us once cornered Larry in an elevator and asked him what
5547             # problem he was solving with this, but he looked as far off into
5548             # the distance as he could in an elevator and said, "It seemed like
5549 0         0 # a good idea at the time."
5550              
5551             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
5552             }
5553             }
5554              
5555             #
5556             # Big5-HKSCS getc (with parameter, without parameter)
5557             #
5558 0     0 0 0 sub Big5HKSCS::getc(;*@) {
5559 0 0       0  
5560 0 0 0     0 my($package) = caller;
5561             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
5562 0         0 croak 'Too many arguments for Big5HKSCS::getc' if @_ and not wantarray;
  0         0  
5563 0         0  
5564 0         0 my @length = sort { $a <=> $b } keys %range_tr;
5565 0         0 my $getc = '';
5566 0 0       0 for my $length ($length[0] .. $length[-1]) {
5567 0 0       0 $getc .= CORE::getc($fh);
5568 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
5569             if ($getc =~ /\A ${Ebig5hkscs::dot_s} \z/oxms) {
5570             return wantarray ? ($getc,@_) : $getc;
5571             }
5572 0 0       0 }
5573             }
5574             return wantarray ? ($getc,@_) : $getc;
5575             }
5576              
5577             #
5578             # Big5-HKSCS length by character
5579             #
5580 0 0   0 1 0 sub Big5HKSCS::length(;$) {
5581              
5582 0         0 local $_ = shift if @_;
5583 0         0  
5584             local @_ = /\G ($q_char) /oxmsg;
5585             return scalar @_;
5586             }
5587              
5588             #
5589             # Big5-HKSCS substr by character
5590             #
5591             BEGIN {
5592              
5593             # P.232 The lvalue Attribute
5594             # in Chapter 6: Subroutines
5595             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5596              
5597             # P.336 The lvalue Attribute
5598             # in Chapter 7: Subroutines
5599             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5600              
5601             # P.144 8.4 Lvalue subroutines
5602             # in Chapter 8: perlsub: Perl subroutines
5603 389 50 0 389 1 228711 # 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  
5604              
5605             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
5606             # vv----------------------*******
5607             sub Big5HKSCS::substr($$;$$) %s {
5608              
5609             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5610              
5611             # If the substring is beyond either end of the string, substr() returns the undefined
5612             # value and produces a warning. When used as an lvalue, specifying a substring that
5613             # is entirely outside the string raises an exception.
5614             # http://perldoc.perl.org/functions/substr.html
5615              
5616             # A return with no argument returns the scalar value undef in scalar context,
5617             # an empty list () in list context, and (naturally) nothing at all in void
5618             # context.
5619              
5620             my $offset = $_[1];
5621             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
5622             return;
5623             }
5624              
5625             # substr($string,$offset,$length,$replacement)
5626             if (@_ == 4) {
5627             my(undef,undef,$length,$replacement) = @_;
5628             my $substr = join '', splice(@char, $offset, $length, $replacement);
5629             $_[0] = join '', @char;
5630              
5631             # return $substr; this doesn't work, don't say "return"
5632             $substr;
5633             }
5634              
5635             # substr($string,$offset,$length)
5636             elsif (@_ == 3) {
5637             my(undef,undef,$length) = @_;
5638             my $octet_offset = 0;
5639             my $octet_length = 0;
5640             if ($offset == 0) {
5641             $octet_offset = 0;
5642             }
5643             elsif ($offset > 0) {
5644             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5645             }
5646             else {
5647             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5648             }
5649             if ($length == 0) {
5650             $octet_length = 0;
5651             }
5652             elsif ($length > 0) {
5653             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
5654             }
5655             else {
5656             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
5657             }
5658             CORE::substr($_[0], $octet_offset, $octet_length);
5659             }
5660              
5661             # substr($string,$offset)
5662             else {
5663             my $octet_offset = 0;
5664             if ($offset == 0) {
5665             $octet_offset = 0;
5666             }
5667             elsif ($offset > 0) {
5668             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5669             }
5670             else {
5671             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5672             }
5673             CORE::substr($_[0], $octet_offset);
5674             }
5675             }
5676             END
5677             }
5678              
5679             #
5680             # Big5-HKSCS index by character
5681             #
5682 0     0 1 0 sub Big5HKSCS::index($$;$) {
5683 0 0       0  
5684 0         0 my $index;
5685             if (@_ == 3) {
5686             $index = Ebig5hkscs::index($_[0], $_[1], CORE::length(Big5HKSCS::substr($_[0], 0, $_[2])));
5687 0         0 }
5688             else {
5689             $index = Ebig5hkscs::index($_[0], $_[1]);
5690 0 0       0 }
5691 0         0  
5692             if ($index == -1) {
5693             return -1;
5694 0         0 }
5695             else {
5696             return Big5HKSCS::length(CORE::substr $_[0], 0, $index);
5697             }
5698             }
5699              
5700             #
5701             # Big5-HKSCS rindex by character
5702             #
5703 0     0 1 0 sub Big5HKSCS::rindex($$;$) {
5704 0 0       0  
5705 0         0 my $rindex;
5706             if (@_ == 3) {
5707             $rindex = Ebig5hkscs::rindex($_[0], $_[1], CORE::length(Big5HKSCS::substr($_[0], 0, $_[2])));
5708 0         0 }
5709             else {
5710             $rindex = Ebig5hkscs::rindex($_[0], $_[1]);
5711 0 0       0 }
5712 0         0  
5713             if ($rindex == -1) {
5714             return -1;
5715 0         0 }
5716             else {
5717             return Big5HKSCS::length(CORE::substr $_[0], 0, $rindex);
5718             }
5719             }
5720              
5721 389     389   6512 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  389         2900  
  389         37796  
5722             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
5723             use vars qw($slash); $slash = 'm//';
5724              
5725             # ord() to ord() or Big5HKSCS::ord()
5726             my $function_ord = 'ord';
5727              
5728             # ord to ord or Big5HKSCS::ord_
5729             my $function_ord_ = 'ord';
5730              
5731             # reverse to reverse or Big5HKSCS::reverse
5732             my $function_reverse = 'reverse';
5733              
5734             # getc to getc or Big5HKSCS::getc
5735             my $function_getc = 'getc';
5736              
5737             # P.1023 Appendix W.9 Multibyte Anchoring
5738             # of ISBN 1-56592-224-7 CJKV Information Processing
5739              
5740             my $anchor = '';
5741 389     389   5736 $anchor = q{${Ebig5hkscs::anchor}};
  389     0   2608  
  389         22852061  
5742              
5743             use vars qw($nest);
5744              
5745             # regexp of nested parens in qqXX
5746              
5747             # P.340 Matching Nested Constructs with Embedded Code
5748             # in Chapter 7: Perl
5749             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5750              
5751             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
5752             [^\x81-\xFE\\()] |
5753             \( (?{$nest++}) |
5754             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5755             [\x81-\xFE][\x00-\xFF] |
5756             \\ [^\x81-\xFEc] |
5757             \\c[\x40-\x5F] |
5758             \\ [\x81-\xFE][\x00-\xFF] |
5759             [\x00-\xFF]
5760             }xms;
5761              
5762             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
5763             [^\x81-\xFE\\{}] |
5764             \{ (?{$nest++}) |
5765             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5766             [\x81-\xFE][\x00-\xFF] |
5767             \\ [^\x81-\xFEc] |
5768             \\c[\x40-\x5F] |
5769             \\ [\x81-\xFE][\x00-\xFF] |
5770             [\x00-\xFF]
5771             }xms;
5772              
5773             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
5774             [^\x81-\xFE\\\[\]] |
5775             \[ (?{$nest++}) |
5776             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5777             [\x81-\xFE][\x00-\xFF] |
5778             \\ [^\x81-\xFEc] |
5779             \\c[\x40-\x5F] |
5780             \\ [\x81-\xFE][\x00-\xFF] |
5781             [\x00-\xFF]
5782             }xms;
5783              
5784             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
5785             [^\x81-\xFE\\<>] |
5786             \< (?{$nest++}) |
5787             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5788             [\x81-\xFE][\x00-\xFF] |
5789             \\ [^\x81-\xFEc] |
5790             \\c[\x40-\x5F] |
5791             \\ [\x81-\xFE][\x00-\xFF] |
5792             [\x00-\xFF]
5793             }xms;
5794              
5795             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
5796             (?: ::)? (?:
5797             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5798             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5799             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5800             ))
5801             }xms;
5802              
5803             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
5804             (?: ::)? (?:
5805             (?>[0-9]+) |
5806             [^\x81-\xFEa-zA-Z_0-9\[\]] |
5807             ^[A-Z] |
5808             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5809             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5810             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5811             ))
5812             }xms;
5813              
5814             my $qq_substr = qr{(?> Char::substr | Big5HKSCS::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
5815             }xms;
5816              
5817             # regexp of nested parens in qXX
5818             my $q_paren = qr{(?{local $nest=0}) (?>(?:
5819             [^\x81-\xFE()] |
5820             [\x81-\xFE][\x00-\xFF] |
5821             \( (?{$nest++}) |
5822             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5823             [\x00-\xFF]
5824             }xms;
5825              
5826             my $q_brace = qr{(?{local $nest=0}) (?>(?:
5827             [^\x81-\xFE\{\}] |
5828             [\x81-\xFE][\x00-\xFF] |
5829             \{ (?{$nest++}) |
5830             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5831             [\x00-\xFF]
5832             }xms;
5833              
5834             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
5835             [^\x81-\xFE\[\]] |
5836             [\x81-\xFE][\x00-\xFF] |
5837             \[ (?{$nest++}) |
5838             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5839             [\x00-\xFF]
5840             }xms;
5841              
5842             my $q_angle = qr{(?{local $nest=0}) (?>(?:
5843             [^\x81-\xFE<>] |
5844             [\x81-\xFE][\x00-\xFF] |
5845             \< (?{$nest++}) |
5846             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5847             [\x00-\xFF]
5848             }xms;
5849              
5850             my $matched = '';
5851             my $s_matched = '';
5852             $matched = q{$Ebig5hkscs::matched};
5853             $s_matched = q{ Ebig5hkscs::s_matched();};
5854              
5855             my $tr_variable = ''; # variable of tr///
5856             my $sub_variable = ''; # variable of s///
5857             my $bind_operator = ''; # =~ or !~
5858              
5859             my @heredoc = (); # here document
5860             my @heredoc_delimiter = ();
5861             my $here_script = ''; # here script
5862              
5863             #
5864             # escape Big5-HKSCS script
5865 0 50   384 0 0 #
5866             sub Big5HKSCS::escape(;$) {
5867             local($_) = $_[0] if @_;
5868              
5869             # P.359 The Study Function
5870             # in Chapter 7: Perl
5871 384         1401 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5872              
5873             study $_; # Yes, I studied study yesterday.
5874              
5875             # while all script
5876              
5877             # 6.14. Matching from Where the Last Pattern Left Off
5878             # in Chapter 6. Pattern Matching
5879             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
5880             # (and so on)
5881              
5882             # one member of Tag-team
5883             #
5884             # P.128 Start of match (or end of previous match): \G
5885             # P.130 Advanced Use of \G with Perl
5886             # in Chapter 3: Overview of Regular Expression Features and Flavors
5887             # P.255 Use leading anchors
5888             # P.256 Expose ^ and \G at the front expressions
5889             # in Chapter 6: Crafting an Efficient Expression
5890             # P.315 "Tag-team" matching with /gc
5891             # in Chapter 7: Perl
5892 384         841 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5893 384         728  
5894 384         1661 my $e_script = '';
5895             while (not /\G \z/oxgc) { # member
5896             $e_script .= Big5HKSCS::escape_token();
5897 187258         338749 }
5898              
5899             return $e_script;
5900             }
5901              
5902             #
5903             # escape Big5-HKSCS token of script
5904             #
5905             sub Big5HKSCS::escape_token {
5906              
5907 384     187258 0 5834 # \n output here document
5908              
5909             my $ignore_modules = join('|', qw(
5910             utf8
5911             bytes
5912             charnames
5913             I18N::Japanese
5914             I18N::Collate
5915             I18N::JExt
5916             File::DosGlob
5917             Wild
5918             Wildcard
5919             Japanese
5920             ));
5921              
5922             # another member of Tag-team
5923             #
5924             # P.315 "Tag-team" matching with /gc
5925             # in Chapter 7: Perl
5926 187258 100 100     240983 # 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          
5927 187258         14704313  
5928 31404 100       42244 if (/\G ( \n ) /oxgc) { # another member (and so on)
5929 31404         56118 my $heredoc = '';
5930             if (scalar(@heredoc_delimiter) >= 1) {
5931 197         280 $slash = 'm//';
5932 197         462  
5933             $heredoc = join '', @heredoc;
5934             @heredoc = ();
5935 197         379  
5936 197         405 # skip here document
5937             for my $heredoc_delimiter (@heredoc_delimiter) {
5938 205         1328 /\G .*? \n $heredoc_delimiter \n/xmsgc;
5939             }
5940 197         401 @heredoc_delimiter = ();
5941              
5942 197         325 $here_script = '';
5943             }
5944             return "\n" . $heredoc;
5945             }
5946 31404         93489  
5947             # ignore space, comment
5948             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
5949              
5950             # if (, elsif (, unless (, while (, until (, given (, and when (
5951              
5952             # given, when
5953              
5954             # P.225 The given Statement
5955             # in Chapter 15: Smart Matching and given-when
5956             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5957              
5958             # P.133 The given Statement
5959             # in Chapter 4: Statements and Declarations
5960             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5961 42620         133006  
5962 3773         6691 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
5963             $slash = 'm//';
5964             return $1;
5965             }
5966              
5967             # scalar variable ($scalar = ...) =~ tr///;
5968             # scalar variable ($scalar = ...) =~ s///;
5969              
5970             # state
5971              
5972             # P.68 Persistent, Private Variables
5973             # in Chapter 4: Subroutines
5974             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5975              
5976             # P.160 Persistent Lexically Scoped Variables: state
5977             # in Chapter 4: Statements and Declarations
5978             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5979              
5980             # (and so on)
5981 3773         22770  
5982             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
5983 170 50       468 my $e_string = e_string($1);
    50          
5984 170         6356  
5985 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
5986 0         0 $tr_variable = $e_string . e_string($1);
5987 0         0 $bind_operator = $2;
5988             $slash = 'm//';
5989             return '';
5990 0         0 }
5991 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
5992 0         0 $sub_variable = $e_string . e_string($1);
5993 0         0 $bind_operator = $2;
5994             $slash = 'm//';
5995             return '';
5996 0         0 }
5997 170         384 else {
5998             $slash = 'div';
5999             return $e_string;
6000             }
6001             }
6002              
6003 170         659 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
6004 4         8 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
6005             $slash = 'div';
6006             return q{Ebig5hkscs::PREMATCH()};
6007             }
6008              
6009 4         16 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
6010 28         61 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
6011             $slash = 'div';
6012             return q{Ebig5hkscs::MATCH()};
6013             }
6014              
6015 28         90 # $', ${'} --> $', ${'}
6016 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
6017             $slash = 'div';
6018             return $1;
6019             }
6020              
6021 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
6022 3         16 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
6023             $slash = 'div';
6024             return q{Ebig5hkscs::POSTMATCH()};
6025             }
6026              
6027             # scalar variable $scalar =~ tr///;
6028             # scalar variable $scalar =~ s///;
6029             # substr() =~ tr///;
6030 3         12 # substr() =~ s///;
6031             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
6032 2878 100       11530 my $scalar = e_string($1);
    100          
6033 2878         11499  
6034 9         20 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6035 9         21 $tr_variable = $scalar;
6036 9         14 $bind_operator = $1;
6037             $slash = 'm//';
6038             return '';
6039 9         29 }
6040 253         449 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6041 253         598 $sub_variable = $scalar;
6042 253         341 $bind_operator = $1;
6043             $slash = 'm//';
6044             return '';
6045 253         710 }
6046 2616         4536 else {
6047             $slash = 'div';
6048             return $scalar;
6049             }
6050             }
6051              
6052 2616         7852 # end of statement
6053             elsif (/\G ( [,;] ) /oxgc) {
6054             $slash = 'm//';
6055 12209         19077  
6056             # clear tr/// variable
6057             $tr_variable = '';
6058 12209         15200  
6059             # clear s/// variable
6060 12209         14604 $sub_variable = '';
6061              
6062 12209         13987 $bind_operator = '';
6063              
6064             return $1;
6065             }
6066              
6067 12209         43042 # bareword
6068             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
6069             return $1;
6070             }
6071              
6072 0         0 # $0 --> $0
6073 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
6074             $slash = 'div';
6075             return $1;
6076 2         6 }
6077 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
6078             $slash = 'div';
6079             return $1;
6080             }
6081              
6082 0         0 # $$ --> $$
6083 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
6084             $slash = 'div';
6085             return $1;
6086             }
6087              
6088             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6089 1         8 # $1, $2, $3 --> $1, $2, $3 otherwise
6090 219         375 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
6091             $slash = 'div';
6092             return e_capture($1);
6093 219         493 }
6094 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
6095             $slash = 'div';
6096             return e_capture($1);
6097             }
6098              
6099 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6100 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
6101             $slash = 'div';
6102             return e_capture($1.'->'.$2);
6103             }
6104              
6105 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6106 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
6107             $slash = 'div';
6108             return e_capture($1.'->'.$2);
6109             }
6110              
6111 0         0 # $$foo
6112 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
6113             $slash = 'div';
6114             return e_capture($1);
6115             }
6116              
6117 0         0 # ${ foo }
6118 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
6119             $slash = 'div';
6120             return '${' . $1 . '}';
6121             }
6122              
6123 0         0 # ${ ... }
6124 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
6125             $slash = 'div';
6126             return e_capture($1);
6127             }
6128              
6129             # variable or function
6130 0         0 # $ @ % & * $ #
6131 605         1019 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) {
6132             $slash = 'div';
6133             return $1;
6134             }
6135             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
6136 605         2035 # $ @ # \ ' " / ? ( ) [ ] < >
6137 103         205 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
6138             $slash = 'div';
6139             return $1;
6140             }
6141              
6142 103         355 # while ()
6143             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
6144             return $1;
6145             }
6146              
6147             # while () --- glob
6148              
6149             # avoid "Error: Runtime exception" of perl version 5.005_03
6150 0         0  
6151             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][\x00-\xFF])+?) > (?>\s*) \) \b /oxgc) {
6152             return 'while ($_ = Ebig5hkscs::glob("' . $1 . '"))';
6153             }
6154              
6155 0         0 # while (glob)
6156             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
6157             return 'while ($_ = Ebig5hkscs::glob_)';
6158             }
6159              
6160 0         0 # while (glob(WILDCARD))
6161             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
6162             return 'while ($_ = Ebig5hkscs::glob';
6163             }
6164 0         0  
  482         1174  
6165             # doit if, doit unless, doit while, doit until, doit for, doit when
6166             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
6167 482         1942  
  19         39  
6168 19         66 # subroutines of package Ebig5hkscs
  0         0  
6169 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         16  
6170 13         40 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
6171 0         0 elsif (/\G \b Big5HKSCS::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         183  
6172 114         359 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         5  
6173 2         6 elsif (/\G \b Big5HKSCS::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Big5HKSCS::escape'; }
  2         4  
6174 2         6 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         3  
6175 2         7 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::chop'; }
  0         0  
6176 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         3  
6177 2         7 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  2         3  
6178 2         7 elsif (/\G \b Big5HKSCS::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Big5HKSCS::index'; }
  2         4  
6179 2         5 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::index'; }
  0         0  
6180 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         5  
6181 2         5 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  2         4  
6182 2         5 elsif (/\G \b Big5HKSCS::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Big5HKSCS::rindex'; }
  1         3  
6183 1         5 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::rindex'; }
  0         0  
6184 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lc'; }
  0         0  
6185 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lcfirst'; }
  0         0  
6186 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::uc'; }
  3         4  
6187             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::ucfirst'; }
6188             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::fc'; }
6189              
6190             # stacked file test operators
6191              
6192             # P.179 File Test Operators
6193             # in Chapter 12: File Tests
6194             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6195              
6196             # P.106 Named Unary and File Test Operators
6197             # in Chapter 3: Unary and Binary Operators
6198             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6199              
6200             # (and so on)
6201 3         10  
  0         0  
6202 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6203 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6204 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6205 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6206 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6207 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  1         3  
6208             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6209             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6210 1         5  
  5         15  
6211 5         21 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6212 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6213 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6214 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6215 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6216 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  1         3  
6217             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6218             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6219 1         5  
  0         0  
6220 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6221 0         0 { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1),$2)"; }
  0         0  
6222 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1),$2)"; }
  0         0  
6223             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest qw($1),"; }
6224 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1),$2)"; }
  0         0  
6225 0         0  
  0         0  
6226 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6227 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6228 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6229 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6230 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  2         5  
6231             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
6232 2         8 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  103         212  
6233 103         372  
  0         0  
6234 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6235 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6236 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6237 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6238 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  2         6  
6239             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6240             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6241 2         30  
  6         13  
6242 6         30 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6243 0         0 { $slash = 'm//'; return "Ebig5hkscs::$1($2)"; }
  0         0  
6244 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1($2)"; }
  50         113  
6245 50         272 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1"; }
  2         8  
6246 2         149 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(::"."$2)"; }
  1         3  
6247 1         4 elsif (/\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-t $2"; }
  3         7  
6248             elsif (/\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lstat'; }
6249             elsif (/\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::stat'; }
6250 3         12  
  0         0  
6251 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
6252 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
6253 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6254 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6255 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6256 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6257             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
6258 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  
6259 0         0  
  0         0  
6260 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
6261 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6262 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6263 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6264 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6265             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6266             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6267 0         0  
  0         0  
6268 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6269 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
6270 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
6271             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
6272 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         5  
6273 2         9  
  2         5  
6274 2         6 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         80  
6275 36         137 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         6  
6276 2         8 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::chr'; }
  2         5  
6277 2         8 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  8         24  
6278 8         36 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
6279 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::glob'; }
  0         0  
6280 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lc_'; }
  0         0  
6281 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lcfirst_'; }
  0         0  
6282 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::uc_'; }
  0         0  
6283 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::ucfirst_'; }
  0         0  
6284 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::fc_'; }
  0         0  
6285             elsif (/\G \b lstat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lstat_'; }
6286 0         0 elsif (/\G \b stat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::stat_'; }
  0         0  
6287             elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
6288 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest_(qw($1))"; }
  0         0  
6289             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC])
6290 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::${1}_"; }
  0         0  
6291              
6292 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
6293 0         0  
  0         0  
6294 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
6295 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
6296 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::chr_'; }
  2         7  
6297 2         9 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
6298 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  4         11  
6299 4         19 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::glob_'; }
  8         23  
6300 8         36 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  2         7  
6301 2         13 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0         0  
6302 0         0 elsif (/\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::opendir$1*"; }
  87         245  
6303             elsif (/\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::opendir$1*"; }
6304             elsif (/\G \b unlink \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::unlink'; }
6305              
6306 87         355 # chdir
6307             elsif (/\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
6308 3         8 $slash = 'm//';
6309              
6310 3         4 my $e = 'Ebig5hkscs::chdir';
6311 3         13  
6312             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6313             $e .= $1;
6314             }
6315 3 50       12  
  3 100       214  
    50          
    50          
    50          
    0          
6316             # end of chdir
6317             if (/\G (?= [,;\)\}\]] ) /oxgc) { return $e; }
6318 0         0  
6319             # chdir scalar value
6320             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return $e . e_string($1); }
6321              
6322 1 0       4 # chdir qq//
  0         0  
6323             elsif (/\G \b (qq) \b /oxgc) {
6324 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq# # --> qr # #
6325 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6326 0         0 while (not /\G \z/oxgc) {
6327 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6328 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq ( ) --> qr ( )
6329 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq { } --> qr { }
6330 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq [ ] --> qr [ ]
6331 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq < > --> qr < >
6332             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq','{','}',$2); } # qq | | --> qr { }
6333 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq * * --> qr * *
6334             }
6335             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6336             }
6337             }
6338              
6339 0 0       0 # chdir q//
  0         0  
6340             elsif (/\G \b (q) \b /oxgc) {
6341 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q# # --> qr # #
6342 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6343 0         0 while (not /\G \z/oxgc) {
6344 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6345 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q ( ) --> qr ( )
6346 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q { } --> qr { }
6347 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q [ ] --> qr [ ]
6348 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q < > --> qr < >
6349             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q','{','}',$2); } # q | | --> qr { }
6350 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q * * --> qr * *
6351             }
6352             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6353             }
6354             }
6355              
6356 0         0 # chdir ''
6357 2         5 elsif (/\G (\') /oxgc) {
6358 2 50       7 my $q_string = '';
  13 50       72  
    100          
    50          
6359 0         0 while (not /\G \z/oxgc) {
6360 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6361 2         7 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
6362             elsif (/\G \' /oxgc) { return $e . e_chdir_q('',"'","'",$q_string); }
6363 11         22 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6364             }
6365             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6366             }
6367              
6368 0         0 # chdir ""
6369 0         0 elsif (/\G (\") /oxgc) {
6370 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6371 0         0 while (not /\G \z/oxgc) {
6372 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6373 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
6374             elsif (/\G \" /oxgc) { return $e . e_chdir('','"','"',$qq_string); }
6375 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6376             }
6377             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6378             }
6379             }
6380              
6381 0         0 # split
6382             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
6383 404         1029 $slash = 'm//';
6384 404         651  
6385 404         1568 my $e = '';
6386             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6387             $e .= $1;
6388             }
6389 401 100       1747  
  404 100       19911  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
6390             # end of split
6391             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Ebig5hkscs::split' . $e; }
6392 3         20  
6393             # split scalar value
6394             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Ebig5hkscs::split' . $e . e_string($1); }
6395 1         6  
6396 0         0 # split literal space
6397 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {qq$1 $2}; }
6398 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; }
6399 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; }
6400 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; }
6401 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; }
6402 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; }
6403 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {q$1 $2}; }
6404 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; }
6405 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; }
6406 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; }
6407 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; }
6408 13         91 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; }
6409             elsif (/\G ' [ ] ' /oxgc) { return 'Ebig5hkscs::split' . $e . qq {' '}; }
6410             elsif (/\G " [ ] " /oxgc) { return 'Ebig5hkscs::split' . $e . qq {" "}; }
6411              
6412 2 0       12 # split qq//
  0         0  
6413             elsif (/\G \b (qq) \b /oxgc) {
6414 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
6415 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6416 0         0 while (not /\G \z/oxgc) {
6417 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6418 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
6419 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
6420 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
6421 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
6422             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
6423 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
6424             }
6425             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6426             }
6427             }
6428              
6429 0 50       0 # split qr//
  124         951  
6430             elsif (/\G \b (qr) \b /oxgc) {
6431 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
6432 124 50       465 else {
  124 50       6309  
    50          
    50          
    50          
    100          
    50          
    50          
6433 0         0 while (not /\G \z/oxgc) {
6434 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6435 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
6436 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
6437 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
6438 56         392 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
6439 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
6440             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
6441 68         324 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
6442             }
6443             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6444             }
6445             }
6446              
6447 0 0       0 # split q//
  0         0  
6448             elsif (/\G \b (q) \b /oxgc) {
6449 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
6450 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6451 0         0 while (not /\G \z/oxgc) {
6452 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6453 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
6454 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
6455 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
6456 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
6457             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
6458 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
6459             }
6460             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6461             }
6462             }
6463              
6464 0 50       0 # split m//
  136         1028  
6465             elsif (/\G \b (m) \b /oxgc) {
6466 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
6467 136 50       516 else {
  136 50       6531  
    50          
    50          
    50          
    100          
    50          
    50          
6468 0         0 while (not /\G \z/oxgc) {
6469 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6470 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
6471 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
6472 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
6473 56         214 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
6474 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
6475             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
6476 80         360 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
6477             }
6478             die __FILE__, ": Search pattern not terminated\n";
6479             }
6480             }
6481              
6482 0         0 # split ''
6483 0         0 elsif (/\G (\') /oxgc) {
6484 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6485 0         0 while (not /\G \z/oxgc) {
6486 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6487 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
6488             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
6489 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6490             }
6491             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6492             }
6493              
6494 0         0 # split ""
6495 0         0 elsif (/\G (\") /oxgc) {
6496 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6497 0         0 while (not /\G \z/oxgc) {
6498 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6499 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
6500             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
6501 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6502             }
6503             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6504             }
6505              
6506 0         0 # split //
6507 125         373 elsif (/\G (\/) /oxgc) {
6508 125 50       390 my $regexp = '';
  558 50       3487  
    100          
    50          
6509 0         0 while (not /\G \z/oxgc) {
6510 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
6511 125         587 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
6512             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
6513 433         1140 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
6514             }
6515             die __FILE__, ": Search pattern not terminated\n";
6516             }
6517             }
6518              
6519             # tr/// or y///
6520              
6521             # about [cdsrbB]* (/B modifier)
6522             #
6523             # P.559 appendix C
6524             # of ISBN 4-89052-384-7 Programming perl
6525             # (Japanese title is: Perl puroguramingu)
6526 0         0  
6527             elsif (/\G \b ( tr | y ) \b /oxgc) {
6528             my $ope = $1;
6529 11 50       136  
6530 11         283 # $1 $2 $3 $4 $5 $6
6531 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
6532             my @tr = ($tr_variable,$2);
6533             return e_tr(@tr,'',$4,$6);
6534 0         0 }
6535 11         23 else {
6536 11 50       34 my $e = '';
  11 50       2142  
    50          
    50          
    50          
    50          
6537             while (not /\G \z/oxgc) {
6538 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6539 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6540 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6541 0         0 while (not /\G \z/oxgc) {
6542 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6543 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
6544 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
6545 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
6546             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
6547 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
6548             }
6549             die __FILE__, ": Transliteration replacement not terminated\n";
6550 0         0 }
6551 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6552 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6553 0         0 while (not /\G \z/oxgc) {
6554 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6555 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
6556 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
6557 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
6558             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
6559 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
6560             }
6561             die __FILE__, ": Transliteration replacement not terminated\n";
6562 0         0 }
6563 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6564 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6565 0         0 while (not /\G \z/oxgc) {
6566 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6567 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
6568 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
6569 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
6570             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
6571 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
6572             }
6573             die __FILE__, ": Transliteration replacement not terminated\n";
6574 0         0 }
6575 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6576 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6577 0         0 while (not /\G \z/oxgc) {
6578 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6579 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
6580 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
6581 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
6582             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
6583 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
6584             }
6585             die __FILE__, ": Transliteration replacement not terminated\n";
6586             }
6587 0         0 # $1 $2 $3 $4 $5 $6
6588 11         47 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
6589             my @tr = ($tr_variable,$2);
6590             return e_tr(@tr,'',$4,$6);
6591 11         37 }
6592             }
6593             die __FILE__, ": Transliteration pattern not terminated\n";
6594             }
6595             }
6596              
6597 0         0 # qq//
6598             elsif (/\G \b (qq) \b /oxgc) {
6599             my $ope = $1;
6600 5897 100       16202  
6601 5897         12480 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
6602 40         56 if (/\G (\#) /oxgc) { # qq# #
6603 40 100       105 my $qq_string = '';
  1948 50       5821  
    100          
    50          
6604 80         266 while (not /\G \z/oxgc) {
6605 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6606 40         94 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
6607             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
6608 1828         3510 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6609             }
6610             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6611             }
6612 0         0  
6613 5857         7959 else {
6614 5857 50       14301 my $e = '';
  5857 50       22747  
    100          
    50          
    100          
    50          
6615             while (not /\G \z/oxgc) {
6616             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6617              
6618 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
6619 0         0 elsif (/\G (\() /oxgc) { # qq ( )
6620 0         0 my $qq_string = '';
6621 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6622 0         0 while (not /\G \z/oxgc) {
6623 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6624             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
6625 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6626 0         0 elsif (/\G (\)) /oxgc) {
6627             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
6628 0         0 else { $qq_string .= $1; }
6629             }
6630 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6631             }
6632             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6633             }
6634              
6635 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
6636 5775         8353 elsif (/\G (\{) /oxgc) { # qq { }
6637 5775         8527 my $qq_string = '';
6638 5775 100       12704 local $nest = 1;
  246229 50       791315  
    100          
    100          
    50          
6639 720         1478 while (not /\G \z/oxgc) {
6640 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1384         1886  
6641             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
6642 1384 100       2430 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  7159         11327  
6643 5775         12712 elsif (/\G (\}) /oxgc) {
6644             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
6645 1384         2825 else { $qq_string .= $1; }
6646             }
6647 236966         488682 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6648             }
6649             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6650             }
6651              
6652 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
6653 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
6654 0         0 my $qq_string = '';
6655 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6656 0         0 while (not /\G \z/oxgc) {
6657 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6658             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
6659 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6660 0         0 elsif (/\G (\]) /oxgc) {
6661             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
6662 0         0 else { $qq_string .= $1; }
6663             }
6664 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6665             }
6666             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6667             }
6668              
6669 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
6670 62         104 elsif (/\G (\<) /oxgc) { # qq < >
6671 62         108 my $qq_string = '';
6672 62 100       173 local $nest = 1;
  2040 50       7464  
    100          
    100          
    50          
6673 22         51 while (not /\G \z/oxgc) {
6674 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  2         5  
6675             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
6676 2 100       3 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  64         149  
6677 62         170 elsif (/\G (\>) /oxgc) {
6678             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
6679 2         4 else { $qq_string .= $1; }
6680             }
6681 1952         4217 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6682             }
6683             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6684             }
6685              
6686 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
6687 20         33 elsif (/\G (\S) /oxgc) { # qq * *
6688 20         28 my $delimiter = $1;
6689 20 50       43 my $qq_string = '';
  840 50       3049  
    100          
    50          
6690 0         0 while (not /\G \z/oxgc) {
6691 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6692 20         50 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
6693             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
6694 820         18179 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6695             }
6696             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6697 0         0 }
6698             }
6699             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6700             }
6701             }
6702              
6703 0         0 # qr//
6704 184 50       503 elsif (/\G \b (qr) \b /oxgc) {
6705 184         751 my $ope = $1;
6706             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
6707             return e_qr($ope,$1,$3,$2,$4);
6708 0         0 }
6709 184         266 else {
6710 184 50       486 my $e = '';
  184 50       4916  
    100          
    50          
    50          
    100          
    50          
    50          
6711 0         0 while (not /\G \z/oxgc) {
6712 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6713 1         5 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
6714 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
6715 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
6716 76         252 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
6717 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
6718             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
6719 107         304 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
6720             }
6721             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6722             }
6723             }
6724              
6725 0         0 # qw//
6726 34 50       101 elsif (/\G \b (qw) \b /oxgc) {
6727 34         100 my $ope = $1;
6728             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
6729             return e_qw($ope,$1,$3,$2);
6730 0         0 }
6731 34         66 else {
6732 34 50       115 my $e = '';
  34 50       274  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6733             while (not /\G \z/oxgc) {
6734 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6735 34         135  
6736             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6737 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6738 0         0  
6739             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6740 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6741 0         0  
6742             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6743 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6744 0         0  
6745             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6746 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6747 0         0  
6748             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6749 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6750             }
6751             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6752             }
6753             }
6754              
6755 0         0 # qx//
6756 3 50       9 elsif (/\G \b (qx) \b /oxgc) {
6757 3         71 my $ope = $1;
6758             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
6759             return e_qq($ope,$1,$3,$2);
6760 0         0 }
6761 3         8 else {
6762 3 50       13 my $e = '';
  3 50       364  
    100          
    50          
    50          
    50          
    50          
6763 0         0 while (not /\G \z/oxgc) {
6764 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6765 2         6 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
6766 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
6767 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
6768 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
6769             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
6770 1         4 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
6771             }
6772             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6773             }
6774             }
6775              
6776 0         0 # q//
6777             elsif (/\G \b (q) \b /oxgc) {
6778             my $ope = $1;
6779              
6780             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
6781              
6782             # avoid "Error: Runtime exception" of perl version 5.005_03
6783 606 50       2049 # (and so on)
6784 606         1946  
6785 0         0 if (/\G (\#) /oxgc) { # q# #
6786 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6787 0         0 while (not /\G \z/oxgc) {
6788 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6789 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
6790             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
6791 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6792             }
6793             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6794             }
6795 0         0  
6796 606         1168 else {
6797 606 50       3451 my $e = '';
  606 100       4094  
    100          
    50          
    100          
    50          
6798             while (not /\G \z/oxgc) {
6799             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6800              
6801 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
6802 1         3 elsif (/\G (\() /oxgc) { # q ( )
6803 1         2 my $q_string = '';
6804 1 50       5 local $nest = 1;
  7 50       53  
    50          
    50          
    100          
    50          
6805 0         0 while (not /\G \z/oxgc) {
6806 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6807 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
6808             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
6809 0 50       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  1         3  
6810 1         3 elsif (/\G (\)) /oxgc) {
6811             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
6812 0         0 else { $q_string .= $1; }
6813             }
6814 6         17 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6815             }
6816             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6817             }
6818              
6819 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
6820 599         1138 elsif (/\G (\{) /oxgc) { # q { }
6821 599         1128 my $q_string = '';
6822 599 50       1811 local $nest = 1;
  8267 50       37719  
    50          
    100          
    100          
    50          
6823 0         0 while (not /\G \z/oxgc) {
6824 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6825 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  114         185  
6826             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
6827 114 100       280 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  713         1774  
6828 599         2225 elsif (/\G (\}) /oxgc) {
6829             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
6830 114         244 else { $q_string .= $1; }
6831             }
6832 7440         15501 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6833             }
6834             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6835             }
6836              
6837 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
6838 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
6839 0         0 my $q_string = '';
6840 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
6841 0         0 while (not /\G \z/oxgc) {
6842 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6843 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
6844             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
6845 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
6846 0         0 elsif (/\G (\]) /oxgc) {
6847             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
6848 0         0 else { $q_string .= $1; }
6849             }
6850 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6851             }
6852             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6853             }
6854              
6855 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
6856 5         10 elsif (/\G (\<) /oxgc) { # q < >
6857 5         11 my $q_string = '';
6858 5 50       16 local $nest = 1;
  82 50       394  
    50          
    50          
    100          
    50          
6859 0         0 while (not /\G \z/oxgc) {
6860 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6861 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
6862             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
6863 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         14  
6864 5         15 elsif (/\G (\>) /oxgc) {
6865             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
6866 0         0 else { $q_string .= $1; }
6867             }
6868 77         155 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6869             }
6870             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6871             }
6872              
6873 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
6874 1         3 elsif (/\G (\S) /oxgc) { # q * *
6875 1         2 my $delimiter = $1;
6876 1 50       5 my $q_string = '';
  14 50       76  
    100          
    50          
6877 0         0 while (not /\G \z/oxgc) {
6878 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6879 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
6880             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
6881 13         27 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6882             }
6883             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6884 0         0 }
6885             }
6886             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6887             }
6888             }
6889              
6890 0         0 # m//
6891 491 50       1509 elsif (/\G \b (m) \b /oxgc) {
6892 491         2971 my $ope = $1;
6893             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
6894             return e_qr($ope,$1,$3,$2,$4);
6895 0         0 }
6896 491         815 else {
6897 491 50       1345 my $e = '';
  491 50       21129  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6898 0         0 while (not /\G \z/oxgc) {
6899 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6900 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
6901 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
6902 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
6903 92         288 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
6904 87         321 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
6905 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
6906             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
6907 312         1121 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
6908             }
6909             die __FILE__, ": Search pattern not terminated\n";
6910             }
6911             }
6912              
6913             # s///
6914              
6915             # about [cegimosxpradlunbB]* (/cg modifier)
6916             #
6917             # P.67 Pattern-Matching Operators
6918             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
6919 0         0  
6920             elsif (/\G \b (s) \b /oxgc) {
6921             my $ope = $1;
6922 290 100       873  
6923 290         4624 # $1 $2 $3 $4 $5 $6
6924             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
6925             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
6926 1         5 }
6927 289         498 else {
6928 289 50       873 my $e = '';
  289 50       30915  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6929             while (not /\G \z/oxgc) {
6930 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6931 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6932 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6933             while (not /\G \z/oxgc) {
6934 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6935 0         0 # $1 $2 $3 $4
6936 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6937 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6938 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6939 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6940 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6941 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6942 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6943             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6944 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6945             }
6946             die __FILE__, ": Substitution replacement not terminated\n";
6947 0         0 }
6948 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6949 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6950             while (not /\G \z/oxgc) {
6951 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6952 0         0 # $1 $2 $3 $4
6953 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6954 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6955 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6956 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6957 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6958 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6959 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6960             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6961 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6962             }
6963             die __FILE__, ": Substitution replacement not terminated\n";
6964 0         0 }
6965 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6966 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
6967             while (not /\G \z/oxgc) {
6968 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6969 0         0 # $1 $2 $3 $4
6970 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6971 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6972 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6973 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6974 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6975             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6976 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6977             }
6978             die __FILE__, ": Substitution replacement not terminated\n";
6979 0         0 }
6980 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6981 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6982             while (not /\G \z/oxgc) {
6983 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6984 0         0 # $1 $2 $3 $4
6985 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6986 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6987 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6988 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6989 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6990 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6991 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6992             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6993 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6994             }
6995             die __FILE__, ": Substitution replacement not terminated\n";
6996             }
6997 0         0 # $1 $2 $3 $4 $5 $6
6998             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
6999             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7000             }
7001 96         284 # $1 $2 $3 $4 $5 $6
7002             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7003             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
7004             }
7005 2         31 # $1 $2 $3 $4 $5 $6
7006             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7007             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7008             }
7009 0         0 # $1 $2 $3 $4 $5 $6
7010             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7011             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7012 191         770 }
7013             }
7014             die __FILE__, ": Substitution pattern not terminated\n";
7015             }
7016             }
7017 0         0  
7018 1         6 # do
7019 0         0 elsif (/\G \b do (?= (?>\s*) \{ ) /oxmsgc) { return 'do'; }
7020 0         0 elsif (/\G \b do (?= (?>\s+) (?: q | qq | qx ) \b) /oxmsgc) { return 'Ebig5hkscs::do'; }
7021 0         0 elsif (/\G \b do (?= (?>\s+) (?>\w+)) /oxmsgc) { return 'do'; }
7022             elsif (/\G \b do (?= (?>\s*) \$ (?> \w+ (?: ::\w+)* ) \( ) /oxmsgc) { return 'do'; }
7023             elsif (/\G \b do \b /oxmsgc) { return 'Ebig5hkscs::do'; }
7024 2         8  
7025 0         0 # require ignore module
7026 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
7027             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# require$1\n$2"; }
7028             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
7029 0         0  
7030 0         0 # require version number
7031 0         0 elsif (/\G \b require (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7032             elsif (/\G \b require (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7033             elsif (/\G \b require (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7034 0         0  
7035             # require bare package name
7036             elsif (/\G \b require (?>\s+) ((?>[A-Za-z_]\w* (?: :: [A-Za-z_]\w*)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7037 18         129  
7038 0         0 # require else
7039             elsif (/\G \b require (?>\s*) ; /oxmsgc) { return 'Ebig5hkscs::require;'; }
7040             elsif (/\G \b require \b /oxmsgc) { return 'Ebig5hkscs::require'; }
7041 1         5  
7042 70         656 # use strict; --> use strict; no strict qw(refs);
7043 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
7044             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
7045             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
7046              
7047 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
7048 3         41 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7049             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
7050             return "use $1; no strict qw(refs);";
7051 0         0 }
7052             else {
7053             return "use $1;";
7054             }
7055 3 0 0     16 }
      0        
7056 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7057             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
7058             return "use $1; no strict qw(refs);";
7059 0         0 }
7060             else {
7061             return "use $1;";
7062             }
7063             }
7064 0         0  
7065 2         17 # ignore use module
7066 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
7067             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# use$1\n$2"; }
7068             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
7069 0         0  
7070 0         0 # ignore no module
7071 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
7072             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# no$1\n$2"; }
7073             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
7074 0         0  
7075 0         0 # use without import
7076 0         0 elsif (/\G \b use (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7077 0         0 elsif (/\G \b use (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7078 0         0 elsif (/\G \b use (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7079 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7080 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7081 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7082 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7083 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7084             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7085             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7086 0         0  
7087             # use with import no parameter
7088             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_use_noparam($1); }
7089 0         0  
7090 0         0 # use with import parameters
7091 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7092 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\xFE']* \') (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7093 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\xFE"]* \") (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7094 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); }
7095 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); }
7096 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); }
7097 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); }
7098             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7099             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); }
7100 0         0  
7101 0         0 # no without unimport
7102 0         0 elsif (/\G \b no (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7103 0         0 elsif (/\G \b no (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7104 0         0 elsif (/\G \b no (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7105 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7106 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7107 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7108 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7109 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7110             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7111             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7112 0         0  
7113             # no with unimport no parameter
7114             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_no_noparam($1); }
7115 0         0  
7116 0         0 # no with unimport parameters
7117 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7118 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\xFE']* \') (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7119 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\xFE"]* \") (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7120 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); }
7121 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); }
7122 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); }
7123 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); }
7124             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7125             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); }
7126 0         0  
7127             # use else
7128             elsif (/\G \b use \b /oxmsgc) { return "use"; }
7129 0         0  
7130             # use else
7131             elsif (/\G \b no \b /oxmsgc) { return "no"; }
7132              
7133 2         9 # ''
7134 3177         10230 elsif (/\G (?
7135 3177 100       8726 my $q_string = '';
  15708 100       55757  
    100          
    50          
7136 8         19 while (not /\G \z/oxgc) {
7137 48         91 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
7138 3177         7875 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
7139             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
7140 12475         27725 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7141             }
7142             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7143             }
7144              
7145 0         0 # ""
7146 3404         8332 elsif (/\G (\") /oxgc) {
7147 3404 100       10724 my $qq_string = '';
  72029 100       213172  
    100          
    50          
7148 109         241 while (not /\G \z/oxgc) {
7149 14         33 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7150 3404         9103 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
7151             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
7152 68502         138092 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
7153             }
7154             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7155             }
7156              
7157 0         0 # ``
7158 37         122 elsif (/\G (\`) /oxgc) {
7159 37 50       149 my $qx_string = '';
  313 50       1965  
    100          
    50          
7160 0         0 while (not /\G \z/oxgc) {
7161 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
7162 37         152 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
7163             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
7164 276         645 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
7165             }
7166             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7167             }
7168              
7169 0         0 # // --- not divide operator (num / num), not defined-or
7170 1231         3106 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
7171 1231 100       4447 my $regexp = '';
  12602 50       42612  
    100          
    50          
7172 11         37 while (not /\G \z/oxgc) {
7173 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7174 1231         3274 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
7175             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
7176 11360         23626 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7177             }
7178             die __FILE__, ": Search pattern not terminated\n";
7179             }
7180              
7181 0         0 # ?? --- not conditional operator (condition ? then : else)
7182 92         252 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
7183 92 50       243 my $regexp = '';
  266 50       1044  
    100          
    50          
7184 0         0 while (not /\G \z/oxgc) {
7185 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7186 92         233 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
7187             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
7188 174         466 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7189             }
7190             die __FILE__, ": Search pattern not terminated\n";
7191             }
7192 0         0  
  0         0  
7193             # <<>> (a safer ARGV)
7194             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
7195 0         0  
  0         0  
7196             # << (bit shift) --- not here document
7197             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
7198              
7199 0         0 # <<~'HEREDOC'
7200 6         14 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
7201 6         15 $slash = 'm//';
7202             my $here_quote = $1;
7203             my $delimiter = $2;
7204 6 50       10  
7205 6         17 # get here document
7206 6         27 if ($here_script eq '') {
7207             $here_script = CORE::substr $_, pos $_;
7208 6 50       30 $here_script =~ s/.*?\n//oxm;
7209 6         70 }
7210 6         18 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7211 6         8 my $heredoc = $1;
7212 6         49 my $indent = $2;
7213 6         20 $heredoc =~ s{^$indent}{}msg; # no /ox
7214             push @heredoc, $heredoc . qq{\n$delimiter\n};
7215             push @heredoc_delimiter, qq{\\s*$delimiter};
7216 6         13 }
7217             else {
7218 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7219             }
7220             return qq{<<'$delimiter'};
7221             }
7222              
7223             # <<~\HEREDOC
7224              
7225             # P.66 2.6.6. "Here" Documents
7226             # in Chapter 2: Bits and Pieces
7227             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7228              
7229             # P.73 "Here" Documents
7230             # in Chapter 2: Bits and Pieces
7231             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7232 6         25  
7233 3         8 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
7234 3         7 $slash = 'm//';
7235             my $here_quote = $1;
7236             my $delimiter = $2;
7237 3 50       9  
7238 3         9 # get here document
7239 3         25 if ($here_script eq '') {
7240             $here_script = CORE::substr $_, pos $_;
7241 3 50       20 $here_script =~ s/.*?\n//oxm;
7242 3         38 }
7243 3         9 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7244 3         6 my $heredoc = $1;
7245 3         36 my $indent = $2;
7246 3         14 $heredoc =~ s{^$indent}{}msg; # no /ox
7247             push @heredoc, $heredoc . qq{\n$delimiter\n};
7248             push @heredoc_delimiter, qq{\\s*$delimiter};
7249 3         10 }
7250             else {
7251 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7252             }
7253             return qq{<<\\$delimiter};
7254             }
7255              
7256 3         13 # <<~"HEREDOC"
7257 6         13 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
7258 6         14 $slash = 'm//';
7259             my $here_quote = $1;
7260             my $delimiter = $2;
7261 6 50       26  
7262 6         18 # get here document
7263 6         31 if ($here_script eq '') {
7264             $here_script = CORE::substr $_, pos $_;
7265 6 50       34 $here_script =~ s/.*?\n//oxm;
7266 6         66 }
7267 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7268 6         11 my $heredoc = $1;
7269 6         49 my $indent = $2;
7270 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
7271             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7272             push @heredoc_delimiter, qq{\\s*$delimiter};
7273 6         15 }
7274             else {
7275 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7276             }
7277             return qq{<<"$delimiter"};
7278             }
7279              
7280 6         24 # <<~HEREDOC
7281 3         10 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
7282 3         10 $slash = 'm//';
7283             my $here_quote = $1;
7284             my $delimiter = $2;
7285 3 50       6  
7286 3         9 # get here document
7287 3         15 if ($here_script eq '') {
7288             $here_script = CORE::substr $_, pos $_;
7289 3 50       16 $here_script =~ s/.*?\n//oxm;
7290 3         38 }
7291 3         10 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7292 3         5 my $heredoc = $1;
7293 3         41 my $indent = $2;
7294 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
7295             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7296             push @heredoc_delimiter, qq{\\s*$delimiter};
7297 3         8 }
7298             else {
7299 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7300             }
7301             return qq{<<$delimiter};
7302             }
7303              
7304 3         15 # <<~`HEREDOC`
7305 6         13 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
7306 6         12 $slash = 'm//';
7307             my $here_quote = $1;
7308             my $delimiter = $2;
7309 6 50       11  
7310 6         12 # get here document
7311 6         20 if ($here_script eq '') {
7312             $here_script = CORE::substr $_, pos $_;
7313 6 50       41 $here_script =~ s/.*?\n//oxm;
7314 6         59 }
7315 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7316 6         14 my $heredoc = $1;
7317 6         53 my $indent = $2;
7318 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
7319             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7320             push @heredoc_delimiter, qq{\\s*$delimiter};
7321 6         15 }
7322             else {
7323 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7324             }
7325             return qq{<<`$delimiter`};
7326             }
7327              
7328 6         25 # <<'HEREDOC'
7329 86         205 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
7330 86         271 $slash = 'm//';
7331             my $here_quote = $1;
7332             my $delimiter = $2;
7333 86 100       163  
7334 86         204 # get here document
7335 83         525 if ($here_script eq '') {
7336             $here_script = CORE::substr $_, pos $_;
7337 83 50       510 $here_script =~ s/.*?\n//oxm;
7338 86         695 }
7339 86         325 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7340             push @heredoc, $1 . qq{\n$delimiter\n};
7341             push @heredoc_delimiter, $delimiter;
7342 86         150 }
7343             else {
7344 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7345             }
7346             return $here_quote;
7347             }
7348              
7349             # <<\HEREDOC
7350              
7351             # P.66 2.6.6. "Here" Documents
7352             # in Chapter 2: Bits and Pieces
7353             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7354              
7355             # P.73 "Here" Documents
7356             # in Chapter 2: Bits and Pieces
7357             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7358 86         336  
7359 2         7 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
7360 2         4 $slash = 'm//';
7361             my $here_quote = $1;
7362             my $delimiter = $2;
7363 2 100       5  
7364 2         5 # get here document
7365 1         7 if ($here_script eq '') {
7366             $here_script = CORE::substr $_, pos $_;
7367 1 50       6 $here_script =~ s/.*?\n//oxm;
7368 2         36 }
7369 2         9 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7370             push @heredoc, $1 . qq{\n$delimiter\n};
7371             push @heredoc_delimiter, $delimiter;
7372 2         5 }
7373             else {
7374 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7375             }
7376             return $here_quote;
7377             }
7378              
7379 2         8 # <<"HEREDOC"
7380 39         111 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
7381 39         145 $slash = 'm//';
7382             my $here_quote = $1;
7383             my $delimiter = $2;
7384 39 100       88  
7385 39         105 # get here document
7386 38         239 if ($here_script eq '') {
7387             $here_script = CORE::substr $_, pos $_;
7388 38 50       280 $here_script =~ s/.*?\n//oxm;
7389 39         514 }
7390 39         142 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7391             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7392             push @heredoc_delimiter, $delimiter;
7393 39         114 }
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 39         169 # <
7401 54         147 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
7402 54         127 $slash = 'm//';
7403             my $here_quote = $1;
7404             my $delimiter = $2;
7405 54 100       117  
7406 54         177 # get here document
7407 51         363 if ($here_script eq '') {
7408             $here_script = CORE::substr $_, pos $_;
7409 51 50       448 $here_script =~ s/.*?\n//oxm;
7410 54         758 }
7411 54         220 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 54         143 }
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 54         237 # <<`HEREDOC`
7422 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
7423 0         0 $slash = 'm//';
7424             my $here_quote = $1;
7425             my $delimiter = $2;
7426 0 0       0  
7427 0         0 # get here document
7428 0         0 if ($here_script eq '') {
7429             $here_script = CORE::substr $_, pos $_;
7430 0 0       0 $here_script =~ s/.*?\n//oxm;
7431 0         0 }
7432 0         0 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 0         0 }
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 0         0 # <<= <=> <= < operator
7443             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
7444             return $1;
7445             }
7446              
7447 13         93 #
7448             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
7449             return $1;
7450             }
7451              
7452             # --- glob
7453              
7454             # avoid "Error: Runtime exception" of perl version 5.005_03
7455 0         0  
7456             elsif (/\G < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][\x00-\xFF])+?) > /oxgc) {
7457             return 'Ebig5hkscs::glob("' . $1 . '")';
7458             }
7459 0         0  
7460             # __DATA__
7461             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
7462 0         0  
7463             # __END__
7464             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
7465              
7466             # \cD Control-D
7467              
7468             # P.68 2.6.8. Other Literal Tokens
7469             # in Chapter 2: Bits and Pieces
7470             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7471              
7472             # P.76 Other Literal Tokens
7473             # in Chapter 2: Bits and Pieces
7474 384         3137 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7475              
7476             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
7477 0         0  
7478             # \cZ Control-Z
7479             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
7480              
7481             # any operator before div
7482             elsif (/\G (
7483             -- | \+\+ |
7484 0         0 [\)\}\]]
  14161         33034  
7485              
7486             ) /oxgc) { $slash = 'div'; return $1; }
7487              
7488             # yada-yada or triple-dot operator
7489             elsif (/\G (
7490 14161         71390 \.\.\.
  7         16  
7491              
7492             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
7493              
7494             # any operator before m//
7495              
7496             # //, //= (defined-or)
7497              
7498             # P.164 Logical Operators
7499             # in Chapter 10: More Control Structures
7500             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7501              
7502             # P.119 C-Style Logical (Short-Circuit) Operators
7503             # in Chapter 3: Unary and Binary Operators
7504             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7505              
7506             # (and so on)
7507              
7508             # ~~
7509              
7510             # P.221 The Smart Match Operator
7511             # in Chapter 15: Smart Matching and given-when
7512             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7513              
7514             # P.112 Smartmatch Operator
7515             # in Chapter 3: Unary and Binary Operators
7516             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7517              
7518             # (and so on)
7519              
7520             elsif (/\G ((?>
7521              
7522             !~~ | !~ | != | ! |
7523             %= | % |
7524             &&= | && | &= | &\.= | &\. | & |
7525             -= | -> | - |
7526             :(?>\s*)= |
7527             : |
7528             <<>> |
7529             <<= | <=> | <= | < |
7530             == | => | =~ | = |
7531             >>= | >> | >= | > |
7532             \*\*= | \*\* | \*= | \* |
7533             \+= | \+ |
7534             \.\. | \.= | \. |
7535             \/\/= | \/\/ |
7536             \/= | \/ |
7537             \? |
7538             \\ |
7539             \^= | \^\.= | \^\. | \^ |
7540             \b x= |
7541             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
7542             ~~ | ~\. | ~ |
7543             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
7544             \b(?: print )\b |
7545              
7546 7         26 [,;\(\{\[]
  23792         54272  
7547              
7548             )) /oxgc) { $slash = 'm//'; return $1; }
7549 23792         115716  
  37734         81053  
7550             # other any character
7551             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
7552              
7553 37734         201832 # system error
7554             else {
7555             die __FILE__, ": Oops, this shouldn't happen!\n";
7556             }
7557             }
7558              
7559 0     3097 0 0 # escape Big5-HKSCS string
7560 3097         8604 sub e_string {
7561             my($string) = @_;
7562 3097         4505 my $e_string = '';
7563              
7564             local $slash = 'm//';
7565              
7566             # P.1024 Appendix W.10 Multibyte Processing
7567             # of ISBN 1-56592-224-7 CJKV Information Processing
7568 3097         4745 # (and so on)
7569              
7570             my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\$q_char|$q_char) /oxmsg;
7571 3097 100 66     28018  
7572 3097 50       15210 # without { ... }
7573 3018         11530 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
7574             if ($string !~ /<
7575             return $string;
7576             }
7577             }
7578 3018         7830  
7579 79 50       242 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          
7580             while ($string !~ /\G \z/oxgc) {
7581             if (0) {
7582             }
7583 606         83033  
7584 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Ebig5hkscs::PREMATCH()]}
7585 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
7586             $e_string .= q{Ebig5hkscs::PREMATCH()};
7587             $slash = 'div';
7588             }
7589              
7590 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Ebig5hkscs::MATCH()]}
7591 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
7592             $e_string .= q{Ebig5hkscs::MATCH()};
7593             $slash = 'div';
7594             }
7595              
7596 0         0 # $', ${'} --> $', ${'}
7597 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
7598             $e_string .= $1;
7599             $slash = 'div';
7600             }
7601              
7602 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Ebig5hkscs::POSTMATCH()]}
7603 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
7604             $e_string .= q{Ebig5hkscs::POSTMATCH()};
7605             $slash = 'div';
7606             }
7607              
7608 0         0 # bareword
7609 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
7610             $e_string .= $1;
7611             $slash = 'div';
7612             }
7613              
7614 0         0 # $0 --> $0
7615 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
7616             $e_string .= $1;
7617             $slash = 'div';
7618 0         0 }
7619 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
7620             $e_string .= $1;
7621             $slash = 'div';
7622             }
7623              
7624 0         0 # $$ --> $$
7625 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
7626             $e_string .= $1;
7627             $slash = 'div';
7628             }
7629              
7630             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7631 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7632 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
7633             $e_string .= e_capture($1);
7634             $slash = 'div';
7635 0         0 }
7636 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
7637             $e_string .= e_capture($1);
7638             $slash = 'div';
7639             }
7640              
7641 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7642 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
7643             $e_string .= e_capture($1.'->'.$2);
7644             $slash = 'div';
7645             }
7646              
7647 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7648 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
7649             $e_string .= e_capture($1.'->'.$2);
7650             $slash = 'div';
7651             }
7652              
7653 0         0 # $$foo
7654 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
7655             $e_string .= e_capture($1);
7656             $slash = 'div';
7657             }
7658              
7659 0         0 # ${ foo }
7660 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
7661             $e_string .= '${' . $1 . '}';
7662             $slash = 'div';
7663             }
7664              
7665 0         0 # ${ ... }
7666 3         14 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
7667             $e_string .= e_capture($1);
7668             $slash = 'div';
7669             }
7670              
7671             # variable or function
7672 3         18 # $ @ % & * $ #
7673 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) {
7674             $e_string .= $1;
7675             $slash = 'div';
7676             }
7677             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
7678 0         0 # $ @ # \ ' " / ? ( ) [ ] < >
7679 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
7680             $e_string .= $1;
7681             $slash = 'div';
7682             }
7683 0         0  
  0         0  
7684 0         0 # subroutines of package Ebig5hkscs
  0         0  
7685 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
7686 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7687 0         0 elsif ($string =~ /\G \b Big5HKSCS::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7688 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
7689 0         0 elsif ($string =~ /\G \b Big5HKSCS::eval \b /oxgc) { $e_string .= 'eval Big5HKSCS::escape'; $slash = 'm//'; }
  0         0  
7690 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
7691 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Ebig5hkscs::chop'; $slash = 'm//'; }
  0         0  
7692 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
7693 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
7694 0         0 elsif ($string =~ /\G \b Big5HKSCS::index \b /oxgc) { $e_string .= 'Big5HKSCS::index'; $slash = 'm//'; }
  0         0  
7695 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Ebig5hkscs::index'; $slash = 'm//'; }
  0         0  
7696 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
7697 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
7698 0         0 elsif ($string =~ /\G \b Big5HKSCS::rindex \b /oxgc) { $e_string .= 'Big5HKSCS::rindex'; $slash = 'm//'; }
  0         0  
7699 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Ebig5hkscs::rindex'; $slash = 'm//'; }
  0         0  
7700 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::lc'; $slash = 'm//'; }
  0         0  
7701 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::lcfirst'; $slash = 'm//'; }
  0         0  
7702 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::uc'; $slash = 'm//'; }
  0         0  
7703             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::ucfirst'; $slash = 'm//'; }
7704 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::fc'; $slash = 'm//'; }
  0         0  
7705 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7706 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7707 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7708 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7709 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7710 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         8  
7711             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7712             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7713 1         3  
  1         7  
7714 1         4 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7715 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7716 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7717 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7718 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7719 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  1         6  
7720             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7721             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7722 1         4  
  0         0  
7723 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7724 0         0 { $e_string .= "Ebig5hkscs::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7725 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7726             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $e_string .= "Ebig5hkscs::filetest qw($1),"; $slash = 'm//'; }
7727 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7728 0         0  
  0         0  
7729 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7730 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7731 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7732 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7733 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  2         10  
7734             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7735 2         5 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         7  
7736 1         5  
  0         0  
7737 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7738 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7739 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7740 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7741 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  2         19  
7742             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7743             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7744 2         7  
  0         0  
7745 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7746 0         0 { $e_string .= "Ebig5hkscs::$1($2)"; $slash = 'm//'; }
  0         0  
7747 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Ebig5hkscs::$1($2)"; $slash = 'm//'; }
  0         0  
7748 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= "Ebig5hkscs::$1"; $slash = 'm//'; }
  0         0  
7749 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "Ebig5hkscs::$1(::"."$2)"; $slash = 'm//'; }
  0         0  
7750 0         0 elsif ($string =~ /\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-t $2"; $slash = 'm//'; }
  0         0  
7751             elsif ($string =~ /\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::lstat'; $slash = 'm//'; }
7752             elsif ($string =~ /\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::stat'; $slash = 'm//'; }
7753 0         0  
  0         0  
7754 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
7755 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7756 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  
7757 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  
7758 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  
7759 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  
7760             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
7761 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  
7762 0         0  
  0         0  
7763 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7764 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  
7765 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  
7766 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  
7767 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  
7768             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7769             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7770 0         0  
  0         0  
7771 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
7772 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7773 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
7774             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
7775 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7776 0         0  
  0         0  
7777 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7778 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7779 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::chr'; $slash = 'm//'; }
  0         0  
7780 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7781 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
7782 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::glob'; $slash = 'm//'; }
  0         0  
7783 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Ebig5hkscs::lc_'; $slash = 'm//'; }
  0         0  
7784 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Ebig5hkscs::lcfirst_'; $slash = 'm//'; }
  0         0  
7785 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Ebig5hkscs::uc_'; $slash = 'm//'; }
  0         0  
7786 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Ebig5hkscs::ucfirst_'; $slash = 'm//'; }
  0         0  
7787 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Ebig5hkscs::fc_'; $slash = 'm//'; }
  0         0  
7788             elsif ($string =~ /\G \b lstat \b /oxgc) { $e_string .= 'Ebig5hkscs::lstat_'; $slash = 'm//'; }
7789 0         0 elsif ($string =~ /\G \b stat \b /oxgc) { $e_string .= 'Ebig5hkscs::stat_'; $slash = 'm//'; }
  0         0  
7790 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7791 0         0 \b /oxgc) { $e_string .= "Ebig5hkscs::filetest_(qw($1))"; $slash = 'm//'; }
  0         0  
7792             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) \b /oxgc) { $e_string .= "Ebig5hkscs::${1}_"; $slash = 'm//'; }
7793 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
7794 0         0  
  0         0  
7795 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7796 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7797 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Ebig5hkscs::chr_'; $slash = 'm//'; }
  0         0  
7798 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7799 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
7800 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Ebig5hkscs::glob_'; $slash = 'm//'; }
  0         0  
7801 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
7802 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
7803 0         0 elsif ($string =~ /\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Ebig5hkscs::opendir$1*"; $slash = 'm//'; }
  0         0  
7804             elsif ($string =~ /\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Ebig5hkscs::opendir$1*"; $slash = 'm//'; }
7805             elsif ($string =~ /\G \b unlink \b /oxgc) { $e_string .= 'Ebig5hkscs::unlink'; $slash = 'm//'; }
7806              
7807 0         0 # chdir
7808             elsif ($string =~ /\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
7809 0         0 $slash = 'm//';
7810              
7811 0         0 $e_string .= 'Ebig5hkscs::chdir';
7812 0         0  
7813             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7814             $e_string .= $1;
7815             }
7816 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
7817             # end of chdir
7818             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return $e_string; }
7819 0         0  
  0         0  
7820             # chdir scalar value
7821             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= e_string($1); next E_STRING_LOOP; }
7822              
7823 0 0       0 # chdir qq//
  0         0  
  0         0  
7824             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7825 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq# # --> qr # #
7826 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7827 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7828 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7829 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
7830 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
7831 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
7832 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
7833             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq','{','}',$2); next E_STRING_LOOP; } # qq | | --> qr { }
7834 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq * * --> qr * *
7835             }
7836             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7837             }
7838             }
7839              
7840 0 0       0 # chdir q//
  0         0  
  0         0  
7841             elsif ($string =~ /\G \b (q) \b /oxgc) {
7842 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q# # --> qr # #
7843 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7844 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7845 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7846 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  
7847 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  
7848 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  
7849 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  
7850             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q','{','}',$2); next E_STRING_LOOP; } # q | | --> qr { }
7851 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 * *
7852             }
7853             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7854             }
7855             }
7856              
7857 0         0 # chdir ''
7858 0         0 elsif ($string =~ /\G (\') /oxgc) {
7859 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7860 0         0 while ($string !~ /\G \z/oxgc) {
7861 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7862 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; }
7863             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_chdir_q('',"'","'",$q_string); next E_STRING_LOOP; }
7864 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7865             }
7866             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7867             }
7868              
7869 0         0 # chdir ""
7870 0         0 elsif ($string =~ /\G (\") /oxgc) {
7871 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
7872 0         0 while ($string !~ /\G \z/oxgc) {
7873 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
7874 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; }
7875             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_chdir('','"','"',$qq_string); next E_STRING_LOOP; }
7876 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
7877             }
7878             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7879             }
7880             }
7881              
7882 0         0 # split
7883             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
7884 0         0 $slash = 'm//';
7885 0         0  
7886 0         0 my $e = '';
7887             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7888             $e .= $1;
7889             }
7890 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          
7891             # end of split
7892             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Ebig5hkscs::split' . $e; }
7893 0         0  
  0         0  
7894             # split scalar value
7895             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . e_string($1); next E_STRING_LOOP; }
7896 0         0  
  0         0  
7897 0         0 # split literal space
  0         0  
7898 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
7899 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7900 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7901 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7902 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7903 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7904 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
7905 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7906 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7907 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7908 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7909 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7910             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {' '}; next E_STRING_LOOP; }
7911             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {" "}; next E_STRING_LOOP; }
7912              
7913 0 0       0 # split qq//
  0         0  
  0         0  
7914             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7915 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
7916 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7917 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7918 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7919 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  
7920 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  
7921 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  
7922 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  
7923             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
7924 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 * *
7925             }
7926             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7927             }
7928             }
7929              
7930 0 0       0 # split qr//
  0         0  
  0         0  
7931             elsif ($string =~ /\G \b (qr) \b /oxgc) {
7932 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
7933 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7934 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7935 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7936 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  
7937 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  
7938 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  
7939 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  
7940 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  
7941             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
7942 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 * *
7943             }
7944             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7945             }
7946             }
7947              
7948 0 0       0 # split q//
  0         0  
  0         0  
7949             elsif ($string =~ /\G \b (q) \b /oxgc) {
7950 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
7951 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7952 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7953 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7954 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  
7955 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  
7956 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  
7957 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  
7958             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
7959 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 * *
7960             }
7961             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7962             }
7963             }
7964              
7965 0 0       0 # split m//
  0         0  
  0         0  
7966             elsif ($string =~ /\G \b (m) \b /oxgc) {
7967 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 # #
7968 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7969 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7970 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7971 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  
7972 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  
7973 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  
7974 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  
7975 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  
7976             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
7977 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 * *
7978             }
7979             die __FILE__, ": Search pattern not terminated\n";
7980             }
7981             }
7982              
7983 0         0 # split ''
7984 0         0 elsif ($string =~ /\G (\') /oxgc) {
7985 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7986 0         0 while ($string !~ /\G \z/oxgc) {
7987 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7988 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
7989             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
7990 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7991             }
7992             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7993             }
7994              
7995 0         0 # split ""
7996 0         0 elsif ($string =~ /\G (\") /oxgc) {
7997 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
7998 0         0 while ($string !~ /\G \z/oxgc) {
7999 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
8000 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
8001             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
8002 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
8003             }
8004             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8005             }
8006              
8007 0         0 # split //
8008 0         0 elsif ($string =~ /\G (\/) /oxgc) {
8009 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
8010 0         0 while ($string !~ /\G \z/oxgc) {
8011 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
8012 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
8013             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
8014 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
8015             }
8016             die __FILE__, ": Search pattern not terminated\n";
8017             }
8018             }
8019              
8020 0         0 # qq//
8021 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
8022 0         0 my $ope = $1;
8023             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
8024             $e_string .= e_qq($ope,$1,$3,$2);
8025 0         0 }
8026 0         0 else {
8027 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8028 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8029 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8030 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
8031 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
8032 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
8033             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
8034 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
8035             }
8036             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8037             }
8038             }
8039              
8040 0         0 # qx//
8041 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
8042 0         0 my $ope = $1;
8043             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
8044             $e_string .= e_qq($ope,$1,$3,$2);
8045 0         0 }
8046 0         0 else {
8047 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8048 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8049 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8050 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
8051 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
8052 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
8053 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
8054             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
8055 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
8056             }
8057             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8058             }
8059             }
8060              
8061 0         0 # q//
8062 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
8063 0         0 my $ope = $1;
8064             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
8065             $e_string .= e_q($ope,$1,$3,$2);
8066 0         0 }
8067 0         0 else {
8068 0 0       0 my $e = '';
  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 (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
8072 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
8073 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
8074             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
8075 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 * *
8076             }
8077             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8078             }
8079             }
8080 0         0  
8081             # ''
8082             elsif ($string =~ /\G (?
8083 44         295  
8084             # ""
8085             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8086 6         61  
8087             # ``
8088             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8089 0         0  
8090             # <<>> (a safer ARGV)
8091             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
8092 0         0  
8093             # <<= <=> <= < operator
8094             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
8095 0         0  
8096             #
8097             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
8098              
8099 0         0 # --- glob
8100             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
8101             $e_string .= 'Ebig5hkscs::glob("' . $1 . '")';
8102             }
8103              
8104 0         0 # << (bit shift) --- not here document
8105 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
8106             $slash = 'm//';
8107             $e_string .= $1;
8108             }
8109              
8110 0         0 # <<~'HEREDOC'
8111 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
8112 0         0 $slash = 'm//';
8113             my $here_quote = $1;
8114             my $delimiter = $2;
8115 0 0       0  
8116 0         0 # get here document
8117 0         0 if ($here_script eq '') {
8118             $here_script = CORE::substr $_, pos $_;
8119 0 0       0 $here_script =~ s/.*?\n//oxm;
8120 0         0 }
8121 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8122 0         0 my $heredoc = $1;
8123 0         0 my $indent = $2;
8124 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8125             push @heredoc, $heredoc . qq{\n$delimiter\n};
8126             push @heredoc_delimiter, qq{\\s*$delimiter};
8127 0         0 }
8128             else {
8129 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8130             }
8131             $e_string .= qq{<<'$delimiter'};
8132             }
8133              
8134 0         0 # <<~\HEREDOC
8135 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
8136 0         0 $slash = 'm//';
8137             my $here_quote = $1;
8138             my $delimiter = $2;
8139 0 0       0  
8140 0         0 # get here document
8141 0         0 if ($here_script eq '') {
8142             $here_script = CORE::substr $_, pos $_;
8143 0 0       0 $here_script =~ s/.*?\n//oxm;
8144 0         0 }
8145 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8146 0         0 my $heredoc = $1;
8147 0         0 my $indent = $2;
8148 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8149             push @heredoc, $heredoc . qq{\n$delimiter\n};
8150             push @heredoc_delimiter, qq{\\s*$delimiter};
8151 0         0 }
8152             else {
8153 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8154             }
8155             $e_string .= qq{<<\\$delimiter};
8156             }
8157              
8158 0         0 # <<~"HEREDOC"
8159 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
8160 0         0 $slash = 'm//';
8161             my $here_quote = $1;
8162             my $delimiter = $2;
8163 0 0       0  
8164 0         0 # get here document
8165 0         0 if ($here_script eq '') {
8166             $here_script = CORE::substr $_, pos $_;
8167 0 0       0 $here_script =~ s/.*?\n//oxm;
8168 0         0 }
8169 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8170 0         0 my $heredoc = $1;
8171 0         0 my $indent = $2;
8172 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8173             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8174             push @heredoc_delimiter, qq{\\s*$delimiter};
8175 0         0 }
8176             else {
8177 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8178             }
8179             $e_string .= qq{<<"$delimiter"};
8180             }
8181              
8182 0         0 # <<~HEREDOC
8183 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
8184 0         0 $slash = 'm//';
8185             my $here_quote = $1;
8186             my $delimiter = $2;
8187 0 0       0  
8188 0         0 # get here document
8189 0         0 if ($here_script eq '') {
8190             $here_script = CORE::substr $_, pos $_;
8191 0 0       0 $here_script =~ s/.*?\n//oxm;
8192 0         0 }
8193 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8194 0         0 my $heredoc = $1;
8195 0         0 my $indent = $2;
8196 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8197             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8198             push @heredoc_delimiter, qq{\\s*$delimiter};
8199 0         0 }
8200             else {
8201 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8202             }
8203             $e_string .= qq{<<$delimiter};
8204             }
8205              
8206 0         0 # <<~`HEREDOC`
8207 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
8208 0         0 $slash = 'm//';
8209             my $here_quote = $1;
8210             my $delimiter = $2;
8211 0 0       0  
8212 0         0 # get here document
8213 0         0 if ($here_script eq '') {
8214             $here_script = CORE::substr $_, pos $_;
8215 0 0       0 $here_script =~ s/.*?\n//oxm;
8216 0         0 }
8217 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8218 0         0 my $heredoc = $1;
8219 0         0 my $indent = $2;
8220 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8221             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8222             push @heredoc_delimiter, qq{\\s*$delimiter};
8223 0         0 }
8224             else {
8225 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8226             }
8227             $e_string .= qq{<<`$delimiter`};
8228             }
8229              
8230 0         0 # <<'HEREDOC'
8231 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
8232 0         0 $slash = 'm//';
8233             my $here_quote = $1;
8234             my $delimiter = $2;
8235 0 0       0  
8236 0         0 # get here document
8237 0         0 if ($here_script eq '') {
8238             $here_script = CORE::substr $_, pos $_;
8239 0 0       0 $here_script =~ s/.*?\n//oxm;
8240 0         0 }
8241 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8242             push @heredoc, $1 . qq{\n$delimiter\n};
8243             push @heredoc_delimiter, $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 .= $here_quote;
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, e_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 # <
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 # <<`HEREDOC`
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             # any operator before div
8336             elsif ($string =~ /\G (
8337             -- | \+\+ |
8338 0         0 [\)\}\]]
  80         146  
8339              
8340             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
8341              
8342             # yada-yada or triple-dot operator
8343             elsif ($string =~ /\G (
8344 80         280 \.\.\.
  0         0  
8345              
8346             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
8347              
8348             # any operator before m//
8349             elsif ($string =~ /\G ((?>
8350              
8351             !~~ | !~ | != | ! |
8352             %= | % |
8353             &&= | && | &= | &\.= | &\. | & |
8354             -= | -> | - |
8355             :(?>\s*)= |
8356             : |
8357             <<>> |
8358             <<= | <=> | <= | < |
8359             == | => | =~ | = |
8360             >>= | >> | >= | > |
8361             \*\*= | \*\* | \*= | \* |
8362             \+= | \+ |
8363             \.\. | \.= | \. |
8364             \/\/= | \/\/ |
8365             \/= | \/ |
8366             \? |
8367             \\ |
8368             \^= | \^\.= | \^\. | \^ |
8369             \b x= |
8370             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
8371             ~~ | ~\. | ~ |
8372             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
8373             \b(?: print )\b |
8374              
8375 0         0 [,;\(\{\[]
  112         319  
8376              
8377             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
8378 112         722  
8379             # other any character
8380             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
8381              
8382 353         1424 # system error
8383             else {
8384             die __FILE__, ": Oops, this shouldn't happen!\n";
8385             }
8386 0         0 }
8387              
8388             return $e_string;
8389             }
8390              
8391             #
8392             # character class
8393 79     5434 0 329 #
8394             sub character_class {
8395 5434 100       11115 my($char,$modifier) = @_;
8396 5434 100       8870  
8397 115         243 if ($char eq '.') {
8398             if ($modifier =~ /s/) {
8399             return '${Ebig5hkscs::dot_s}';
8400 23         63 }
8401             else {
8402             return '${Ebig5hkscs::dot}';
8403             }
8404 92         203 }
8405             else {
8406             return Ebig5hkscs::classic_character_class($char);
8407             }
8408             }
8409              
8410             #
8411             # escape capture ($1, $2, $3, ...)
8412             #
8413 5319     637 0 10207 sub e_capture {
8414 637         2717  
8415             return join '', '${Ebig5hkscs::capture(', $_[0], ')}';
8416             return join '', '${', $_[0], '}';
8417             }
8418              
8419             #
8420             # escape transliteration (tr/// or y///)
8421 0     11 0 0 #
8422 11         778 sub e_tr {
8423 11   100     25 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
8424             my $e_tr = '';
8425 11         32 $modifier ||= '';
8426              
8427             $slash = 'div';
8428 11         21  
8429             # quote character class 1
8430             $charclass = q_tr($charclass);
8431 11         30  
8432             # quote character class 2
8433             $charclass2 = q_tr($charclass2);
8434 11 50       23  
8435 11 0       375 # /b /B modifier
8436 0         0 if ($modifier =~ tr/bB//d) {
8437             if ($variable eq '') {
8438             $e_tr = qq{tr$charclass$e$charclass2$modifier};
8439 0         0 }
8440             else {
8441             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
8442             }
8443 0 100       0 }
8444 11         29 else {
8445             if ($variable eq '') {
8446             $e_tr = qq{Ebig5hkscs::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
8447 2         7 }
8448             else {
8449             $e_tr = qq{Ebig5hkscs::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
8450             }
8451             }
8452 9         43  
8453 11         20 # clear tr/// variable
8454             $tr_variable = '';
8455 11         184 $bind_operator = '';
8456              
8457             return $e_tr;
8458             }
8459              
8460             #
8461             # quote for escape transliteration (tr/// or y///)
8462 11     22 0 77 #
8463             sub q_tr {
8464             my($charclass) = @_;
8465 22 50       144  
    0          
    0          
    0          
    0          
    0          
8466 22         60 # quote character class
8467             if ($charclass !~ /'/oxms) {
8468             return e_q('', "'", "'", $charclass); # --> q' '
8469 22         43 }
8470             elsif ($charclass !~ /\//oxms) {
8471             return e_q('q', '/', '/', $charclass); # --> q/ /
8472 0         0 }
8473             elsif ($charclass !~ /\#/oxms) {
8474             return e_q('q', '#', '#', $charclass); # --> q# #
8475 0         0 }
8476             elsif ($charclass !~ /[\<\>]/oxms) {
8477             return e_q('q', '<', '>', $charclass); # --> q< >
8478 0         0 }
8479             elsif ($charclass !~ /[\(\)]/oxms) {
8480             return e_q('q', '(', ')', $charclass); # --> q( )
8481 0         0 }
8482             elsif ($charclass !~ /[\{\}]/oxms) {
8483             return e_q('q', '{', '}', $charclass); # --> q{ }
8484 0         0 }
8485 0 0       0 else {
8486 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8487             if ($charclass !~ /\Q$char\E/xms) {
8488             return e_q('q', $char, $char, $charclass);
8489             }
8490             }
8491 0         0 }
8492              
8493             return e_q('q', '{', '}', $charclass);
8494             }
8495              
8496             #
8497             # escape q string (q//, '')
8498 0     3967 0 0 #
8499             sub e_q {
8500 3967         11531 my($ope,$delimiter,$end_delimiter,$string) = @_;
8501              
8502 3967         5969 $slash = 'div';
8503 3967         25682  
8504             my @char = $string =~ / \G (?>$q_char) /oxmsg;
8505             for (my $i=0; $i <= $#char; $i++) {
8506 3967 100 100     11773  
    100 100        
8507 21301         128738 # escape last octet of multiple-octet
8508             if ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
8509             $char[$i] = $1 . '\\' . $2;
8510 1         6 }
8511             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8512             $char[$i] = $1 . '\\' . $2;
8513 22 100 100     89 }
8514 3967         15863 }
8515             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8516             $char[-1] = $1 . '\\' . $2;
8517 204         657 }
8518 3967         23097  
8519             return join '', $ope, $delimiter, @char, $end_delimiter;
8520             return join '', $ope, $delimiter, $string, $end_delimiter;
8521             }
8522              
8523             #
8524             # escape qq string (qq//, "", qx//, ``)
8525 0     9552 0 0 #
8526             sub e_qq {
8527 9552         23021 my($ope,$delimiter,$end_delimiter,$string) = @_;
8528              
8529 9552         13610 $slash = 'div';
8530 9552         12049  
8531             my $left_e = 0;
8532             my $right_e = 0;
8533 9552         13352  
8534             # split regexp
8535             my @char = $string =~ /\G((?>
8536             [^\x81-\xFE\\\$]|[\x81-\xFE][\x00-\xFF] |
8537             \\x\{ (?>[0-9A-Fa-f]+) \} |
8538             \\o\{ (?>[0-7]+) \} |
8539             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8540             \\ $q_char |
8541             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8542             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8543             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8544             \$ (?>\s* [0-9]+) |
8545             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8546             \$ \$ (?![\w\{]) |
8547             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8548             $q_char
8549 9552         390715 ))/oxmsg;
8550              
8551             for (my $i=0; $i <= $#char; $i++) {
8552 9552 50 66     31221  
    50 33        
    100          
    100          
    50          
8553 310109         1021275 # "\L\u" --> "\u\L"
8554             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8555             @char[$i,$i+1] = @char[$i+1,$i];
8556             }
8557              
8558 0         0 # "\U\l" --> "\l\U"
8559             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8560             @char[$i,$i+1] = @char[$i+1,$i];
8561             }
8562              
8563 0         0 # octal escape sequence
8564             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8565             $char[$i] = Ebig5hkscs::octchr($1);
8566             }
8567              
8568 1         5 # hexadecimal escape sequence
8569             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8570             $char[$i] = Ebig5hkscs::hexchr($1);
8571             }
8572              
8573 1         6 # \N{CHARNAME} --> N{CHARNAME}
8574             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8575             $char[$i] = $1;
8576 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          
8577              
8578             if (0) {
8579             }
8580              
8581             # escape last octet of multiple-octet
8582 310109         2902470 # my $metachar = qr/[\@\\\|]/oxms; # '|' is for qx//, ``, open(), and system()
8583 0         0 # variable $delimiter and $end_delimiter can be ''
8584             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\@\\\|$delimiter$end_delimiter]) \z/xms) {
8585             $char[$i] = $1 . '\\' . $2;
8586             }
8587              
8588             # \F
8589             #
8590             # P.69 Table 2-6. Translation escapes
8591             # in Chapter 2: Bits and Pieces
8592             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8593             # (and so on)
8594              
8595 1342 50       6075 # \u \l \U \L \F \Q \E
8596 647         1614 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8597             if ($right_e < $left_e) {
8598             $char[$i] = '\\' . $char[$i];
8599             }
8600             }
8601             elsif ($char[$i] eq '\u') {
8602              
8603             # "STRING @{[ LIST EXPR ]} MORE STRING"
8604              
8605             # P.257 Other Tricks You Can Do with Hard References
8606             # in Chapter 8: References
8607             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
8608              
8609             # P.353 Other Tricks You Can Do with Hard References
8610             # in Chapter 8: References
8611             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8612              
8613 0         0 # (and so on)
8614 0         0  
8615             $char[$i] = '@{[Ebig5hkscs::ucfirst qq<';
8616             $left_e++;
8617 0         0 }
8618 0         0 elsif ($char[$i] eq '\l') {
8619             $char[$i] = '@{[Ebig5hkscs::lcfirst qq<';
8620             $left_e++;
8621 0         0 }
8622 0         0 elsif ($char[$i] eq '\U') {
8623             $char[$i] = '@{[Ebig5hkscs::uc qq<';
8624             $left_e++;
8625 0         0 }
8626 6         9 elsif ($char[$i] eq '\L') {
8627             $char[$i] = '@{[Ebig5hkscs::lc qq<';
8628             $left_e++;
8629 6         13 }
8630 9         16 elsif ($char[$i] eq '\F') {
8631             $char[$i] = '@{[Ebig5hkscs::fc qq<';
8632             $left_e++;
8633 9         20 }
8634 0         0 elsif ($char[$i] eq '\Q') {
8635             $char[$i] = '@{[CORE::quotemeta qq<';
8636             $left_e++;
8637 0 50       0 }
8638 12         26 elsif ($char[$i] eq '\E') {
8639 12         15 if ($right_e < $left_e) {
8640             $char[$i] = '>]}';
8641             $right_e++;
8642 12         26 }
8643             else {
8644             $char[$i] = '';
8645             }
8646 0         0 }
8647 0 0       0 elsif ($char[$i] eq '\Q') {
8648 0         0 while (1) {
8649             if (++$i > $#char) {
8650 0 0       0 last;
8651 0         0 }
8652             if ($char[$i] eq '\E') {
8653             last;
8654             }
8655             }
8656             }
8657             elsif ($char[$i] eq '\E') {
8658             }
8659              
8660             # $0 --> $0
8661             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8662             }
8663             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8664             }
8665              
8666             # $$ --> $$
8667             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8668             }
8669              
8670             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8671 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8672             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8673             $char[$i] = e_capture($1);
8674 415         1104 }
8675             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8676             $char[$i] = e_capture($1);
8677             }
8678              
8679 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8680             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8681             $char[$i] = e_capture($1.'->'.$2);
8682             }
8683              
8684 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8685             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8686             $char[$i] = e_capture($1.'->'.$2);
8687             }
8688              
8689 0         0 # $$foo
8690             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8691             $char[$i] = e_capture($1);
8692             }
8693              
8694 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
8695             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8696             $char[$i] = '@{[Ebig5hkscs::PREMATCH()]}';
8697             }
8698              
8699 44         143 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
8700             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8701             $char[$i] = '@{[Ebig5hkscs::MATCH()]}';
8702             }
8703              
8704 45         156 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
8705             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8706             $char[$i] = '@{[Ebig5hkscs::POSTMATCH()]}';
8707             }
8708              
8709             # ${ foo } --> ${ foo }
8710             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8711             }
8712              
8713 33         104 # ${ ... }
8714             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8715             $char[$i] = e_capture($1);
8716             }
8717             }
8718 0 100       0  
8719 9552         20157 # return string
8720             if ($left_e > $right_e) {
8721 3         19 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
8722             }
8723             return join '', $ope, $delimiter, @char, $end_delimiter;
8724             }
8725              
8726             #
8727             # escape qw string (qw//)
8728 9549     34 0 89254 #
8729             sub e_qw {
8730 34         168 my($ope,$delimiter,$end_delimiter,$string) = @_;
8731              
8732             $slash = 'div';
8733 34         68  
  34         334  
8734 621 50       1192 # choice again delimiter
    0          
    0          
    0          
    0          
8735 34         172 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
8736             if (not $octet{$end_delimiter}) {
8737             return join '', $ope, $delimiter, $string, $end_delimiter;
8738 34         260 }
8739             elsif (not $octet{')'}) {
8740             return join '', $ope, '(', $string, ')';
8741 0         0 }
8742             elsif (not $octet{'}'}) {
8743             return join '', $ope, '{', $string, '}';
8744 0         0 }
8745             elsif (not $octet{']'}) {
8746             return join '', $ope, '[', $string, ']';
8747 0         0 }
8748             elsif (not $octet{'>'}) {
8749             return join '', $ope, '<', $string, '>';
8750 0         0 }
8751 0 0       0 else {
8752 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8753             if (not $octet{$char}) {
8754             return join '', $ope, $char, $string, $char;
8755             }
8756             }
8757             }
8758 0         0  
8759 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
8760 0         0 my @string = CORE::split(/\s+/, $string);
8761 0         0 for my $string (@string) {
8762 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
8763 0         0 for my $octet (@octet) {
8764             if ($octet =~ /\A (['\\]) \z/oxms) {
8765             $octet = '\\' . $1;
8766 0         0 }
8767             }
8768 0         0 $string = join '', @octet;
  0         0  
8769             }
8770             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
8771             }
8772              
8773             #
8774             # escape here document (<<"HEREDOC", <
8775 0     108 0 0 #
8776             sub e_heredoc {
8777 108         326 my($string) = @_;
8778              
8779 108         197 $slash = 'm//';
8780              
8781 108         381 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
8782 108         193  
8783             my $left_e = 0;
8784             my $right_e = 0;
8785 108         156  
8786             # split regexp
8787             my @char = $string =~ /\G((?>
8788             [^\x81-\xFE\\\$]|[\x81-\xFE][\x00-\xFF] |
8789             \\x\{ (?>[0-9A-Fa-f]+) \} |
8790             \\o\{ (?>[0-7]+) \} |
8791             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8792             \\ $q_char |
8793             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8794             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8795             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8796             \$ (?>\s* [0-9]+) |
8797             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8798             \$ \$ (?![\w\{]) |
8799             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8800             $q_char
8801 108         10691 ))/oxmsg;
8802              
8803             for (my $i=0; $i <= $#char; $i++) {
8804 108 50 66     615  
    50 33        
    100          
    100          
    50          
8805 3355         10567 # "\L\u" --> "\u\L"
8806             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8807             @char[$i,$i+1] = @char[$i+1,$i];
8808             }
8809              
8810 0         0 # "\U\l" --> "\l\U"
8811             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8812             @char[$i,$i+1] = @char[$i+1,$i];
8813             }
8814              
8815 0         0 # octal escape sequence
8816             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8817             $char[$i] = Ebig5hkscs::octchr($1);
8818             }
8819              
8820 1         4 # hexadecimal escape sequence
8821             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8822             $char[$i] = Ebig5hkscs::hexchr($1);
8823             }
8824              
8825 1         4 # \N{CHARNAME} --> N{CHARNAME}
8826             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8827             $char[$i] = $1;
8828 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          
8829              
8830             if (0) {
8831             }
8832 3355         30324  
8833 0         0 # escape character
8834             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
8835             $char[$i] = $1 . '\\' . $2;
8836             }
8837              
8838 57 50       224 # \u \l \U \L \F \Q \E
8839 72         184 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8840             if ($right_e < $left_e) {
8841             $char[$i] = '\\' . $char[$i];
8842             }
8843 0         0 }
8844 0         0 elsif ($char[$i] eq '\u') {
8845             $char[$i] = '@{[Ebig5hkscs::ucfirst qq<';
8846             $left_e++;
8847 0         0 }
8848 0         0 elsif ($char[$i] eq '\l') {
8849             $char[$i] = '@{[Ebig5hkscs::lcfirst qq<';
8850             $left_e++;
8851 0         0 }
8852 0         0 elsif ($char[$i] eq '\U') {
8853             $char[$i] = '@{[Ebig5hkscs::uc qq<';
8854             $left_e++;
8855 0         0 }
8856 6         9 elsif ($char[$i] eq '\L') {
8857             $char[$i] = '@{[Ebig5hkscs::lc qq<';
8858             $left_e++;
8859 6         12 }
8860 0         0 elsif ($char[$i] eq '\F') {
8861             $char[$i] = '@{[Ebig5hkscs::fc qq<';
8862             $left_e++;
8863 0         0 }
8864 0         0 elsif ($char[$i] eq '\Q') {
8865             $char[$i] = '@{[CORE::quotemeta qq<';
8866             $left_e++;
8867 0 50       0 }
8868 3         10 elsif ($char[$i] eq '\E') {
8869 3         5 if ($right_e < $left_e) {
8870             $char[$i] = '>]}';
8871             $right_e++;
8872 3         7 }
8873             else {
8874             $char[$i] = '';
8875             }
8876 0         0 }
8877 0 0       0 elsif ($char[$i] eq '\Q') {
8878 0         0 while (1) {
8879             if (++$i > $#char) {
8880 0 0       0 last;
8881 0         0 }
8882             if ($char[$i] eq '\E') {
8883             last;
8884             }
8885             }
8886             }
8887             elsif ($char[$i] eq '\E') {
8888             }
8889              
8890             # $0 --> $0
8891             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8892             }
8893             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8894             }
8895              
8896             # $$ --> $$
8897             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8898             }
8899              
8900             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8901 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8902             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8903             $char[$i] = e_capture($1);
8904 0         0 }
8905             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8906             $char[$i] = e_capture($1);
8907             }
8908              
8909 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8910             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8911             $char[$i] = e_capture($1.'->'.$2);
8912             }
8913              
8914 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8915             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8916             $char[$i] = e_capture($1.'->'.$2);
8917             }
8918              
8919 0         0 # $$foo
8920             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8921             $char[$i] = e_capture($1);
8922             }
8923              
8924 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
8925             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8926             $char[$i] = '@{[Ebig5hkscs::PREMATCH()]}';
8927             }
8928              
8929 8         47 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
8930             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8931             $char[$i] = '@{[Ebig5hkscs::MATCH()]}';
8932             }
8933              
8934 8         54 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
8935             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8936             $char[$i] = '@{[Ebig5hkscs::POSTMATCH()]}';
8937             }
8938              
8939             # ${ foo } --> ${ foo }
8940             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8941             }
8942              
8943 6         37 # ${ ... }
8944             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8945             $char[$i] = e_capture($1);
8946             }
8947             }
8948 0 100       0  
8949 108         401 # return string
8950             if ($left_e > $right_e) {
8951 3         26 return join '', @char, '>]}' x ($left_e - $right_e);
8952             }
8953             return join '', @char;
8954             }
8955              
8956             #
8957             # escape regexp (m//, qr//)
8958 105     1835 0 965 #
8959 1835   100     7636 sub e_qr {
8960             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
8961 1835         7825 $modifier ||= '';
8962 1835 50       3365  
8963 1835         4895 $modifier =~ tr/p//d;
8964 0         0 if ($modifier =~ /([adlu])/oxms) {
8965 0 0       0 my $line = 0;
8966 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
8967 0         0 if ($filename ne __FILE__) {
8968             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
8969             last;
8970 0         0 }
8971             }
8972             die qq{Unsupported modifier "$1" used at line $line.\n};
8973 0         0 }
8974              
8975             $slash = 'div';
8976 1835 100       2939  
    100          
8977 1835         5403 # literal null string pattern
8978 8         9 if ($string eq '') {
8979 8         10 $modifier =~ tr/bB//d;
8980             $modifier =~ tr/i//d;
8981             return join '', $ope, $delimiter, $end_delimiter, $modifier;
8982             }
8983              
8984             # /b /B modifier
8985             elsif ($modifier =~ tr/bB//d) {
8986 8 50       38  
8987 240         556 # choice again delimiter
8988 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
8989 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
8990 0         0 my %octet = map {$_ => 1} @char;
8991 0         0 if (not $octet{')'}) {
8992             $delimiter = '(';
8993             $end_delimiter = ')';
8994 0         0 }
8995 0         0 elsif (not $octet{'}'}) {
8996             $delimiter = '{';
8997             $end_delimiter = '}';
8998 0         0 }
8999 0         0 elsif (not $octet{']'}) {
9000             $delimiter = '[';
9001             $end_delimiter = ']';
9002 0         0 }
9003 0         0 elsif (not $octet{'>'}) {
9004             $delimiter = '<';
9005             $end_delimiter = '>';
9006 0         0 }
9007 0 0       0 else {
9008 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9009 0         0 if (not $octet{$char}) {
9010 0         0 $delimiter = $char;
9011             $end_delimiter = $char;
9012             last;
9013             }
9014             }
9015             }
9016 0 100 100     0 }
9017 240         1289  
9018             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9019             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
9020 90         578 }
9021             else {
9022             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9023             }
9024 150 100       929 }
9025 1587         5179  
9026             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9027             my $metachar = qr/[\@\\|[\]{^]/oxms;
9028 1587         6414  
9029             # split regexp
9030             my @char = $string =~ /\G((?>
9031             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
9032             \\x (?>[0-9A-Fa-f]{1,2}) |
9033             \\ (?>[0-7]{2,3}) |
9034             \\c [\x40-\x5F] |
9035             \\x\{ (?>[0-9A-Fa-f]+) \} |
9036             \\o\{ (?>[0-7]+) \} |
9037             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9038             \\ $q_char |
9039             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9040             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9041             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9042             [\$\@] $qq_variable |
9043             \$ (?>\s* [0-9]+) |
9044             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9045             \$ \$ (?![\w\{]) |
9046             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9047             \[\^ |
9048             \[\: (?>[a-z]+) :\] |
9049             \[\:\^ (?>[a-z]+) :\] |
9050             \(\? |
9051             $q_char
9052             ))/oxmsg;
9053 1587 50       141411  
9054 1587         17367 # choice again delimiter
  0         0  
9055 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9056 0         0 my %octet = map {$_ => 1} @char;
9057 0         0 if (not $octet{')'}) {
9058             $delimiter = '(';
9059             $end_delimiter = ')';
9060 0         0 }
9061 0         0 elsif (not $octet{'}'}) {
9062             $delimiter = '{';
9063             $end_delimiter = '}';
9064 0         0 }
9065 0         0 elsif (not $octet{']'}) {
9066             $delimiter = '[';
9067             $end_delimiter = ']';
9068 0         0 }
9069 0         0 elsif (not $octet{'>'}) {
9070             $delimiter = '<';
9071             $end_delimiter = '>';
9072 0         0 }
9073 0 0       0 else {
9074 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9075 0         0 if (not $octet{$char}) {
9076 0         0 $delimiter = $char;
9077             $end_delimiter = $char;
9078             last;
9079             }
9080             }
9081             }
9082 0         0 }
9083 1587         2415  
9084 1587         2078 my $left_e = 0;
9085             my $right_e = 0;
9086             for (my $i=0; $i <= $#char; $i++) {
9087 1587 50 66     4545  
    50 66        
    100          
    100          
    100          
    100          
9088 5514         28536 # "\L\u" --> "\u\L"
9089             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9090             @char[$i,$i+1] = @char[$i+1,$i];
9091             }
9092              
9093 0         0 # "\U\l" --> "\l\U"
9094             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9095             @char[$i,$i+1] = @char[$i+1,$i];
9096             }
9097              
9098 0         0 # octal escape sequence
9099             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9100             $char[$i] = Ebig5hkscs::octchr($1);
9101             }
9102              
9103 1         4 # hexadecimal escape sequence
9104             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9105             $char[$i] = Ebig5hkscs::hexchr($1);
9106             }
9107              
9108             # \b{...} --> b\{...}
9109             # \B{...} --> B\{...}
9110             # \N{CHARNAME} --> N\{CHARNAME}
9111             # \p{PROPERTY} --> p\{PROPERTY}
9112 1         5 # \P{PROPERTY} --> P\{PROPERTY}
9113             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9114             $char[$i] = $1 . '\\' . $2;
9115             }
9116              
9117 6         26 # \p, \P, \X --> p, P, X
9118             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9119             $char[$i] = $1;
9120 4 100 100     11 }
    100 100        
    100 100        
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
9121              
9122             if (0) {
9123             }
9124 5514         38760  
9125 0         0 # escape last octet of multiple-octet
9126             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9127             $char[$i] = $1 . '\\' . $2;
9128             }
9129              
9130 77 50 33     417 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
9131 6         157 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9132             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)) {
9133             $char[$i] .= join '', splice @char, $i+1, 3;
9134 0         0 }
9135             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)) {
9136             $char[$i] .= join '', splice @char, $i+1, 2;
9137 0         0 }
9138             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)) {
9139             $char[$i] .= join '', splice @char, $i+1, 1;
9140             }
9141             }
9142              
9143 0         0 # open character class [...]
9144             elsif ($char[$i] eq '[') {
9145             my $left = $i;
9146              
9147             # [] make die "Unmatched [] in regexp ...\n"
9148 586 100       1047 # (and so on)
9149 586         1597  
9150             if ($char[$i+1] eq ']') {
9151             $i++;
9152 3         4 }
9153 586 50       743  
9154 2583         4153 while (1) {
9155             if (++$i > $#char) {
9156 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9157 2583         4027 }
9158             if ($char[$i] eq ']') {
9159             my $right = $i;
9160 586 100       747  
9161 586         2997 # [...]
  90         205  
9162             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9163             splice @char, $left, $right-$left+1, sprintf(q{@{[Ebig5hkscs::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9164 270         430 }
9165             else {
9166             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
9167 496         2112 }
9168 586         1077  
9169             $i = $left;
9170             last;
9171             }
9172             }
9173             }
9174              
9175 586         1933 # open character class [^...]
9176             elsif ($char[$i] eq '[^') {
9177             my $left = $i;
9178              
9179             # [^] make die "Unmatched [] in regexp ...\n"
9180 328 100       491 # (and so on)
9181 328         693  
9182             if ($char[$i+1] eq ']') {
9183             $i++;
9184 5         9 }
9185 328 50       460  
9186 1447         2065 while (1) {
9187             if (++$i > $#char) {
9188 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9189 1447         2082 }
9190             if ($char[$i] eq ']') {
9191             my $right = $i;
9192 328 100       370  
9193 328         1999 # [^...]
  90         209  
9194             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9195             splice @char, $left, $right-$left+1, sprintf(q{@{[Ebig5hkscs::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9196 270         452 }
9197             else {
9198             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9199 238         741 }
9200 328         689  
9201             $i = $left;
9202             last;
9203             }
9204             }
9205             }
9206              
9207 328         911 # rewrite character class or escape character
9208             elsif (my $char = character_class($char[$i],$modifier)) {
9209             $char[$i] = $char;
9210             }
9211              
9212 215 50       572 # /i modifier
9213 238         504 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
9214             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
9215             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
9216 238         499 }
9217             else {
9218             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
9219             }
9220             }
9221              
9222 0 50       0 # \u \l \U \L \F \Q \E
9223 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9224             if ($right_e < $left_e) {
9225             $char[$i] = '\\' . $char[$i];
9226             }
9227 0         0 }
9228 0         0 elsif ($char[$i] eq '\u') {
9229             $char[$i] = '@{[Ebig5hkscs::ucfirst qq<';
9230             $left_e++;
9231 0         0 }
9232 0         0 elsif ($char[$i] eq '\l') {
9233             $char[$i] = '@{[Ebig5hkscs::lcfirst qq<';
9234             $left_e++;
9235 0         0 }
9236 1         3 elsif ($char[$i] eq '\U') {
9237             $char[$i] = '@{[Ebig5hkscs::uc qq<';
9238             $left_e++;
9239 1         4 }
9240 1         2 elsif ($char[$i] eq '\L') {
9241             $char[$i] = '@{[Ebig5hkscs::lc qq<';
9242             $left_e++;
9243 1         4 }
9244 9         19 elsif ($char[$i] eq '\F') {
9245             $char[$i] = '@{[Ebig5hkscs::fc qq<';
9246             $left_e++;
9247 9         22 }
9248 22         43 elsif ($char[$i] eq '\Q') {
9249             $char[$i] = '@{[CORE::quotemeta qq<';
9250             $left_e++;
9251 22 50       58 }
9252 33         72 elsif ($char[$i] eq '\E') {
9253 33         54 if ($right_e < $left_e) {
9254             $char[$i] = '>]}';
9255             $right_e++;
9256 33         82 }
9257             else {
9258             $char[$i] = '';
9259             }
9260 0         0 }
9261 0 0       0 elsif ($char[$i] eq '\Q') {
9262 0         0 while (1) {
9263             if (++$i > $#char) {
9264 0 0       0 last;
9265 0         0 }
9266             if ($char[$i] eq '\E') {
9267             last;
9268             }
9269             }
9270             }
9271             elsif ($char[$i] eq '\E') {
9272             }
9273              
9274 0 0       0 # $0 --> $0
9275 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9276             if ($ignorecase) {
9277             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9278             }
9279 0 0       0 }
9280 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9281             if ($ignorecase) {
9282             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9283             }
9284             }
9285              
9286             # $$ --> $$
9287             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9288             }
9289              
9290             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9291 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9292 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9293 0         0 $char[$i] = e_capture($1);
9294             if ($ignorecase) {
9295             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9296             }
9297 0         0 }
9298 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9299 0         0 $char[$i] = e_capture($1);
9300             if ($ignorecase) {
9301             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9302             }
9303             }
9304              
9305 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
9306 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) {
9307 0         0 $char[$i] = e_capture($1.'->'.$2);
9308             if ($ignorecase) {
9309             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9310             }
9311             }
9312              
9313 0         0 # $$foo{ ... } --> $ $foo->{ ... }
9314 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) {
9315 0         0 $char[$i] = e_capture($1.'->'.$2);
9316             if ($ignorecase) {
9317             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9318             }
9319             }
9320              
9321 0         0 # $$foo
9322 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
9323 0         0 $char[$i] = e_capture($1);
9324             if ($ignorecase) {
9325             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9326             }
9327             }
9328              
9329 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
9330 8         24 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
9331             if ($ignorecase) {
9332             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::PREMATCH())]}';
9333 0         0 }
9334             else {
9335             $char[$i] = '@{[Ebig5hkscs::PREMATCH()]}';
9336             }
9337             }
9338              
9339 8 50       23 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
9340 8         24 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
9341             if ($ignorecase) {
9342             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::MATCH())]}';
9343 0         0 }
9344             else {
9345             $char[$i] = '@{[Ebig5hkscs::MATCH()]}';
9346             }
9347             }
9348              
9349 8 50       28 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
9350 6         20 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
9351             if ($ignorecase) {
9352             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::POSTMATCH())]}';
9353 0         0 }
9354             else {
9355             $char[$i] = '@{[Ebig5hkscs::POSTMATCH()]}';
9356             }
9357             }
9358              
9359 6 0       18 # ${ foo }
9360 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) {
9361             if ($ignorecase) {
9362             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9363             }
9364             }
9365              
9366 0         0 # ${ ... }
9367 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
9368 0         0 $char[$i] = e_capture($1);
9369             if ($ignorecase) {
9370             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9371             }
9372             }
9373              
9374 0         0 # $scalar or @array
9375 31 100       121 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
9376 31         116 $char[$i] = e_string($char[$i]);
9377             if ($ignorecase) {
9378             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9379             }
9380             }
9381              
9382 4 100 66     18 # quote character before ? + * {
    50          
9383             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9384             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
9385 188         1992 }
9386 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9387 0         0 my $char = $char[$i-1];
9388             if ($char[$i] eq '{') {
9389             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
9390 0         0 }
9391             else {
9392             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
9393             }
9394 0         0 }
9395             else {
9396             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9397             }
9398             }
9399             }
9400 187         838  
9401 1587 50       3182 # make regexp string
9402 1587 0 0     3419 $modifier =~ tr/i//d;
9403 0         0 if ($left_e > $right_e) {
9404             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9405             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
9406 0         0 }
9407             else {
9408             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
9409 0 100 100     0 }
9410 1587         8912 }
9411             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9412             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
9413 94         840 }
9414             else {
9415             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9416             }
9417             }
9418              
9419             #
9420             # double quote stuff
9421 1493     540 0 12936 #
9422             sub qq_stuff {
9423             my($delimiter,$end_delimiter,$stuff) = @_;
9424 540 100       948  
9425 540         1213 # scalar variable or array variable
9426             if ($stuff =~ /\A [\$\@] /oxms) {
9427             return $stuff;
9428             }
9429 300         1008  
  240         629  
9430 280         758 # quote by delimiter
9431 240 50       722 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
9432 240 50       395 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9433 240 50       344 next if $char eq $delimiter;
9434 240         415 next if $char eq $end_delimiter;
9435             if (not $octet{$char}) {
9436             return join '', 'qq', $char, $stuff, $char;
9437 240         888 }
9438             }
9439             return join '', 'qq', '<', $stuff, '>';
9440             }
9441              
9442             #
9443             # escape regexp (m'', qr'', and m''b, qr''b)
9444 0     163 0 0 #
9445 163   100     840 sub e_qr_q {
9446             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9447 163         520 $modifier ||= '';
9448 163 50       285  
9449 163         500 $modifier =~ tr/p//d;
9450 0         0 if ($modifier =~ /([adlu])/oxms) {
9451 0 0       0 my $line = 0;
9452 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9453 0         0 if ($filename ne __FILE__) {
9454             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9455             last;
9456 0         0 }
9457             }
9458             die qq{Unsupported modifier "$1" used at line $line.\n};
9459 0         0 }
9460              
9461             $slash = 'div';
9462 163 100       268  
    100          
9463 163         438 # literal null string pattern
9464 8         11 if ($string eq '') {
9465 8         9 $modifier =~ tr/bB//d;
9466             $modifier =~ tr/i//d;
9467             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9468             }
9469              
9470 8         38 # with /b /B modifier
9471             elsif ($modifier =~ tr/bB//d) {
9472             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
9473             }
9474              
9475 89         242 # without /b /B modifier
9476             else {
9477             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
9478             }
9479             }
9480              
9481             #
9482             # escape regexp (m'', qr'')
9483 66     66 0 213 #
9484             sub e_qr_qt {
9485 66 100       171 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9486              
9487             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9488 66         186  
9489             # split regexp
9490             my @char = $string =~ /\G((?>
9491             [^\x81-\xFE\\\[\$\@\/] |
9492             [\x81-\xFE][\x00-\xFF] |
9493             \[\^ |
9494             \[\: (?>[a-z]+) \:\] |
9495             \[\:\^ (?>[a-z]+) \:\] |
9496             [\$\@\/] |
9497             \\ (?:$q_char) |
9498             (?:$q_char)
9499             ))/oxmsg;
9500 66         692  
9501 66 100 100     241 # unescape character
    50 100        
    50 66        
    50          
    50          
    100          
    50          
9502             for (my $i=0; $i <= $#char; $i++) {
9503             if (0) {
9504             }
9505 79         918  
9506 0         0 # escape last octet of multiple-octet
9507             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9508             $char[$i] = $1 . '\\' . $2;
9509             }
9510              
9511 2         13 # open character class [...]
9512 0 0       0 elsif ($char[$i] eq '[') {
9513 0         0 my $left = $i;
9514             if ($char[$i+1] eq ']') {
9515 0         0 $i++;
9516 0 0       0 }
9517 0         0 while (1) {
9518             if (++$i > $#char) {
9519 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9520 0         0 }
9521             if ($char[$i] eq ']') {
9522             my $right = $i;
9523 0         0  
9524             # [...]
9525 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
9526 0         0  
9527             $i = $left;
9528             last;
9529             }
9530             }
9531             }
9532              
9533 0         0 # open character class [^...]
9534 0 0       0 elsif ($char[$i] eq '[^') {
9535 0         0 my $left = $i;
9536             if ($char[$i+1] eq ']') {
9537 0         0 $i++;
9538 0 0       0 }
9539 0         0 while (1) {
9540             if (++$i > $#char) {
9541 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9542 0         0 }
9543             if ($char[$i] eq ']') {
9544             my $right = $i;
9545 0         0  
9546             # [^...]
9547 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9548 0         0  
9549             $i = $left;
9550             last;
9551             }
9552             }
9553             }
9554              
9555 0         0 # escape $ @ / and \
9556             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9557             $char[$i] = '\\' . $char[$i];
9558             }
9559              
9560 0         0 # rewrite character class or escape character
9561             elsif (my $char = character_class($char[$i],$modifier)) {
9562             $char[$i] = $char;
9563             }
9564              
9565 0 50       0 # /i modifier
9566 16         41 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
9567             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
9568             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
9569 16         39 }
9570             else {
9571             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
9572             }
9573             }
9574              
9575 0 0       0 # quote character before ? + * {
9576             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9577             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
9578 0         0 }
9579             else {
9580             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9581             }
9582             }
9583 0         0 }
9584 66         143  
9585             $delimiter = '/';
9586 66         83 $end_delimiter = '/';
9587 66         112  
9588             $modifier =~ tr/i//d;
9589             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9590             }
9591              
9592             #
9593             # escape regexp (m''b, qr''b)
9594 66     89 0 456 #
9595             sub e_qr_qb {
9596             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9597 89         229  
9598             # split regexp
9599             my @char = $string =~ /\G ((?>[^\\]|\\\\|[\x00-\xFF])) /oxmsg;
9600 89         379  
9601 89 50       267 # unescape character
    50          
9602             for (my $i=0; $i <= $#char; $i++) {
9603             if (0) {
9604             }
9605 199         662  
9606             # remain \\
9607             elsif ($char[$i] eq '\\\\') {
9608             }
9609              
9610 0         0 # escape $ @ / and \
9611             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9612             $char[$i] = '\\' . $char[$i];
9613             }
9614 0         0 }
9615 89         147  
9616 89         114 $delimiter = '/';
9617             $end_delimiter = '/';
9618             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9619             }
9620              
9621             #
9622             # escape regexp (s/here//)
9623 89     194 0 523 #
9624 194   100     563 sub e_s1 {
9625             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9626 194         703 $modifier ||= '';
9627 194 50       318  
9628 194         684 $modifier =~ tr/p//d;
9629 0         0 if ($modifier =~ /([adlu])/oxms) {
9630 0 0       0 my $line = 0;
9631 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9632 0         0 if ($filename ne __FILE__) {
9633             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9634             last;
9635 0         0 }
9636             }
9637             die qq{Unsupported modifier "$1" used at line $line.\n};
9638 0         0 }
9639              
9640             $slash = 'div';
9641 194 100       323  
    100          
9642 194         707 # literal null string pattern
9643 8         9 if ($string eq '') {
9644 8         9 $modifier =~ tr/bB//d;
9645             $modifier =~ tr/i//d;
9646             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9647             }
9648              
9649             # /b /B modifier
9650             elsif ($modifier =~ tr/bB//d) {
9651 8 50       52  
9652 44         84 # choice again delimiter
9653 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
9654 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
9655 0         0 my %octet = map {$_ => 1} @char;
9656 0         0 if (not $octet{')'}) {
9657             $delimiter = '(';
9658             $end_delimiter = ')';
9659 0         0 }
9660 0         0 elsif (not $octet{'}'}) {
9661             $delimiter = '{';
9662             $end_delimiter = '}';
9663 0         0 }
9664 0         0 elsif (not $octet{']'}) {
9665             $delimiter = '[';
9666             $end_delimiter = ']';
9667 0         0 }
9668 0         0 elsif (not $octet{'>'}) {
9669             $delimiter = '<';
9670             $end_delimiter = '>';
9671 0         0 }
9672 0 0       0 else {
9673 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9674 0         0 if (not $octet{$char}) {
9675 0         0 $delimiter = $char;
9676             $end_delimiter = $char;
9677             last;
9678             }
9679             }
9680             }
9681 0         0 }
9682 44         53  
9683 44         52 my $prematch = '';
9684             $prematch = q{(\G[\x00-\xFF]*?)};
9685             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9686 44 100       272 }
9687 142         473  
9688             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9689             my $metachar = qr/[\@\\|[\]{^]/oxms;
9690 142         601  
9691             # split regexp
9692             my @char = $string =~ /\G((?>
9693             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
9694             \\ (?>[1-9][0-9]*) |
9695             \\g (?>\s*) (?>[1-9][0-9]*) |
9696             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9697             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9698             \\x (?>[0-9A-Fa-f]{1,2}) |
9699             \\ (?>[0-7]{2,3}) |
9700             \\c [\x40-\x5F] |
9701             \\x\{ (?>[0-9A-Fa-f]+) \} |
9702             \\o\{ (?>[0-7]+) \} |
9703             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9704             \\ $q_char |
9705             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9706             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9707             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9708             [\$\@] $qq_variable |
9709             \$ (?>\s* [0-9]+) |
9710             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9711             \$ \$ (?![\w\{]) |
9712             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9713             \[\^ |
9714             \[\: (?>[a-z]+) :\] |
9715             \[\:\^ (?>[a-z]+) :\] |
9716             \(\? |
9717             $q_char
9718             ))/oxmsg;
9719 142 50       64686  
9720 142         1124 # choice again delimiter
  0         0  
9721 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9722 0         0 my %octet = map {$_ => 1} @char;
9723 0         0 if (not $octet{')'}) {
9724             $delimiter = '(';
9725             $end_delimiter = ')';
9726 0         0 }
9727 0         0 elsif (not $octet{'}'}) {
9728             $delimiter = '{';
9729             $end_delimiter = '}';
9730 0         0 }
9731 0         0 elsif (not $octet{']'}) {
9732             $delimiter = '[';
9733             $end_delimiter = ']';
9734 0         0 }
9735 0         0 elsif (not $octet{'>'}) {
9736             $delimiter = '<';
9737             $end_delimiter = '>';
9738 0         0 }
9739 0 0       0 else {
9740 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9741 0         0 if (not $octet{$char}) {
9742 0         0 $delimiter = $char;
9743             $end_delimiter = $char;
9744             last;
9745             }
9746             }
9747             }
9748             }
9749 0         0  
  142         324  
9750             # count '('
9751 476         925 my $parens = grep { $_ eq '(' } @char;
9752 142         240  
9753 142         243 my $left_e = 0;
9754             my $right_e = 0;
9755             for (my $i=0; $i <= $#char; $i++) {
9756 142 50 33     418  
    50 33        
    100          
    100          
    50          
    50          
9757 397         2506 # "\L\u" --> "\u\L"
9758             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9759             @char[$i,$i+1] = @char[$i+1,$i];
9760             }
9761              
9762 0         0 # "\U\l" --> "\l\U"
9763             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9764             @char[$i,$i+1] = @char[$i+1,$i];
9765             }
9766              
9767 0         0 # octal escape sequence
9768             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9769             $char[$i] = Ebig5hkscs::octchr($1);
9770             }
9771              
9772 1         4 # hexadecimal escape sequence
9773             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9774             $char[$i] = Ebig5hkscs::hexchr($1);
9775             }
9776              
9777             # \b{...} --> b\{...}
9778             # \B{...} --> B\{...}
9779             # \N{CHARNAME} --> N\{CHARNAME}
9780             # \p{PROPERTY} --> p\{PROPERTY}
9781 1         5 # \P{PROPERTY} --> P\{PROPERTY}
9782             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9783             $char[$i] = $1 . '\\' . $2;
9784             }
9785              
9786 0         0 # \p, \P, \X --> p, P, X
9787             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9788             $char[$i] = $1;
9789 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          
9790              
9791             if (0) {
9792             }
9793 397         4440  
9794 0         0 # escape last octet of multiple-octet
9795             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9796             $char[$i] = $1 . '\\' . $2;
9797             }
9798              
9799 23 0 0     117 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
9800 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9801             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)) {
9802             $char[$i] .= join '', splice @char, $i+1, 3;
9803 0         0 }
9804             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)) {
9805             $char[$i] .= join '', splice @char, $i+1, 2;
9806 0         0 }
9807             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)) {
9808             $char[$i] .= join '', splice @char, $i+1, 1;
9809             }
9810             }
9811              
9812 0         0 # open character class [...]
9813 20 50       44 elsif ($char[$i] eq '[') {
9814 20         67 my $left = $i;
9815             if ($char[$i+1] eq ']') {
9816 0         0 $i++;
9817 20 50       41 }
9818 79         137 while (1) {
9819             if (++$i > $#char) {
9820 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9821 79         223 }
9822             if ($char[$i] eq ']') {
9823             my $right = $i;
9824 20 50       43  
9825 20         151 # [...]
  0         0  
9826             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9827             splice @char, $left, $right-$left+1, sprintf(q{@{[Ebig5hkscs::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9828 0         0 }
9829             else {
9830             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
9831 20         155 }
9832 20         43  
9833             $i = $left;
9834             last;
9835             }
9836             }
9837             }
9838              
9839 20         66 # open character class [^...]
9840 0 0       0 elsif ($char[$i] eq '[^') {
9841 0         0 my $left = $i;
9842             if ($char[$i+1] eq ']') {
9843 0         0 $i++;
9844 0 0       0 }
9845 0         0 while (1) {
9846             if (++$i > $#char) {
9847 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9848 0         0 }
9849             if ($char[$i] eq ']') {
9850             my $right = $i;
9851 0 0       0  
9852 0         0 # [^...]
  0         0  
9853             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9854             splice @char, $left, $right-$left+1, sprintf(q{@{[Ebig5hkscs::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9855 0         0 }
9856             else {
9857             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9858 0         0 }
9859 0         0  
9860             $i = $left;
9861             last;
9862             }
9863             }
9864             }
9865              
9866 0         0 # rewrite character class or escape character
9867             elsif (my $char = character_class($char[$i],$modifier)) {
9868             $char[$i] = $char;
9869             }
9870              
9871 11 50       29 # /i modifier
9872 11         25 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
9873             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
9874             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
9875 11         33 }
9876             else {
9877             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
9878             }
9879             }
9880              
9881 0 50       0 # \u \l \U \L \F \Q \E
9882 8         25 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9883             if ($right_e < $left_e) {
9884             $char[$i] = '\\' . $char[$i];
9885             }
9886 0         0 }
9887 0         0 elsif ($char[$i] eq '\u') {
9888             $char[$i] = '@{[Ebig5hkscs::ucfirst qq<';
9889             $left_e++;
9890 0         0 }
9891 0         0 elsif ($char[$i] eq '\l') {
9892             $char[$i] = '@{[Ebig5hkscs::lcfirst qq<';
9893             $left_e++;
9894 0         0 }
9895 0         0 elsif ($char[$i] eq '\U') {
9896             $char[$i] = '@{[Ebig5hkscs::uc qq<';
9897             $left_e++;
9898 0         0 }
9899 0         0 elsif ($char[$i] eq '\L') {
9900             $char[$i] = '@{[Ebig5hkscs::lc qq<';
9901             $left_e++;
9902 0         0 }
9903 0         0 elsif ($char[$i] eq '\F') {
9904             $char[$i] = '@{[Ebig5hkscs::fc qq<';
9905             $left_e++;
9906 0         0 }
9907 7         17 elsif ($char[$i] eq '\Q') {
9908             $char[$i] = '@{[CORE::quotemeta qq<';
9909             $left_e++;
9910 7 50       17 }
9911 7         19 elsif ($char[$i] eq '\E') {
9912 7         11 if ($right_e < $left_e) {
9913             $char[$i] = '>]}';
9914             $right_e++;
9915 7         17 }
9916             else {
9917             $char[$i] = '';
9918             }
9919 0         0 }
9920 0 0       0 elsif ($char[$i] eq '\Q') {
9921 0         0 while (1) {
9922             if (++$i > $#char) {
9923 0 0       0 last;
9924 0         0 }
9925             if ($char[$i] eq '\E') {
9926             last;
9927             }
9928             }
9929             }
9930             elsif ($char[$i] eq '\E') {
9931             }
9932              
9933             # \0 --> \0
9934             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
9935             }
9936              
9937             # \g{N}, \g{-N}
9938              
9939             # P.108 Using Simple Patterns
9940             # in Chapter 7: In the World of Regular Expressions
9941             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
9942              
9943             # P.221 Capturing
9944             # in Chapter 5: Pattern Matching
9945             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
9946              
9947             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
9948             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9949             }
9950              
9951 0 0       0 # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
9952 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9953             if ($1 <= $parens) {
9954             $char[$i] = '\\g{' . ($1 + 1) . '}';
9955             }
9956             }
9957              
9958 0 0       0 # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
9959 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9960             if ($1 <= $parens) {
9961             $char[$i] = '\\g' . ($1 + 1);
9962             }
9963             }
9964              
9965 0 0       0 # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
9966 0         0 elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9967             if ($1 <= $parens) {
9968             $char[$i] = '\\' . ($1 + 1);
9969             }
9970             }
9971              
9972 0 0       0 # $0 --> $0
9973 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9974             if ($ignorecase) {
9975             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9976             }
9977 0 0       0 }
9978 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9979             if ($ignorecase) {
9980             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9981             }
9982             }
9983              
9984             # $$ --> $$
9985             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9986             }
9987              
9988             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9989 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9990 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9991 0         0 $char[$i] = e_capture($1);
9992             if ($ignorecase) {
9993             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9994             }
9995 0         0 }
9996 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9997 0         0 $char[$i] = e_capture($1);
9998             if ($ignorecase) {
9999             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10000             }
10001             }
10002              
10003 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10004 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) {
10005 0         0 $char[$i] = e_capture($1.'->'.$2);
10006             if ($ignorecase) {
10007             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10008             }
10009             }
10010              
10011 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10012 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) {
10013 0         0 $char[$i] = e_capture($1.'->'.$2);
10014             if ($ignorecase) {
10015             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10016             }
10017             }
10018              
10019 0         0 # $$foo
10020 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10021 0         0 $char[$i] = e_capture($1);
10022             if ($ignorecase) {
10023             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10024             }
10025             }
10026              
10027 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
10028 4         15 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10029             if ($ignorecase) {
10030             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::PREMATCH())]}';
10031 0         0 }
10032             else {
10033             $char[$i] = '@{[Ebig5hkscs::PREMATCH()]}';
10034             }
10035             }
10036              
10037 4 50       17 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
10038 4         16 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10039             if ($ignorecase) {
10040             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::MATCH())]}';
10041 0         0 }
10042             else {
10043             $char[$i] = '@{[Ebig5hkscs::MATCH()]}';
10044             }
10045             }
10046              
10047 4 50       17 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
10048 3         14 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10049             if ($ignorecase) {
10050             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::POSTMATCH())]}';
10051 0         0 }
10052             else {
10053             $char[$i] = '@{[Ebig5hkscs::POSTMATCH()]}';
10054             }
10055             }
10056              
10057 3 0       13 # ${ foo }
10058 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) {
10059             if ($ignorecase) {
10060             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10061             }
10062             }
10063              
10064 0         0 # ${ ... }
10065 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10066 0         0 $char[$i] = e_capture($1);
10067             if ($ignorecase) {
10068             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10069             }
10070             }
10071              
10072 0         0 # $scalar or @array
10073 13 50       52 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10074 13         61 $char[$i] = e_string($char[$i]);
10075             if ($ignorecase) {
10076             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10077             }
10078             }
10079              
10080 0 50       0 # quote character before ? + * {
10081             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10082             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10083 23         129 }
10084             else {
10085             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10086             }
10087             }
10088             }
10089 23         124  
10090 142         327 # make regexp string
10091 142         357 my $prematch = '';
10092 142 50       254 $prematch = "($anchor)";
10093 142         370 $modifier =~ tr/i//d;
10094             if ($left_e > $right_e) {
10095 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
10096             }
10097             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10098             }
10099              
10100             #
10101             # escape regexp (s'here'' or s'here''b)
10102 142     96 0 1545 #
10103 96   100     212 sub e_s1_q {
10104             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10105 96         246 $modifier ||= '';
10106 96 50       136  
10107 96         262 $modifier =~ tr/p//d;
10108 0         0 if ($modifier =~ /([adlu])/oxms) {
10109 0 0       0 my $line = 0;
10110 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10111 0         0 if ($filename ne __FILE__) {
10112             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10113             last;
10114 0         0 }
10115             }
10116             die qq{Unsupported modifier "$1" used at line $line.\n};
10117 0         0 }
10118              
10119             $slash = 'div';
10120 96 100       132  
    100          
10121 96         206 # literal null string pattern
10122 8         10 if ($string eq '') {
10123 8         9 $modifier =~ tr/bB//d;
10124             $modifier =~ tr/i//d;
10125             return join '', $ope, $delimiter, $end_delimiter, $modifier;
10126             }
10127              
10128 8         42 # with /b /B modifier
10129             elsif ($modifier =~ tr/bB//d) {
10130             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
10131             }
10132              
10133 44         79 # without /b /B modifier
10134             else {
10135             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
10136             }
10137             }
10138              
10139             #
10140             # escape regexp (s'here'')
10141 44     44 0 89 #
10142             sub e_s1_qt {
10143 44 100       100 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10144              
10145             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10146 44         102  
10147             # split regexp
10148             my @char = $string =~ /\G((?>
10149             [^\x81-\xFE\\\[\$\@\/] |
10150             [\x81-\xFE][\x00-\xFF] |
10151             \[\^ |
10152             \[\: (?>[a-z]+) \:\] |
10153             \[\:\^ (?>[a-z]+) \:\] |
10154             [\$\@\/] |
10155             \\ (?:$q_char) |
10156             (?:$q_char)
10157             ))/oxmsg;
10158 44         465  
10159 44 50 100     128 # unescape character
    50 100        
    50 66        
    50          
    100          
    100          
    50          
10160             for (my $i=0; $i <= $#char; $i++) {
10161             if (0) {
10162             }
10163 62         648  
10164 0         0 # escape last octet of multiple-octet
10165             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10166             $char[$i] = $1 . '\\' . $2;
10167             }
10168              
10169 0         0 # open character class [...]
10170 0 0       0 elsif ($char[$i] eq '[') {
10171 0         0 my $left = $i;
10172             if ($char[$i+1] eq ']') {
10173 0         0 $i++;
10174 0 0       0 }
10175 0         0 while (1) {
10176             if (++$i > $#char) {
10177 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10178 0         0 }
10179             if ($char[$i] eq ']') {
10180             my $right = $i;
10181 0         0  
10182             # [...]
10183 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
10184 0         0  
10185             $i = $left;
10186             last;
10187             }
10188             }
10189             }
10190              
10191 0         0 # open character class [^...]
10192 0 0       0 elsif ($char[$i] eq '[^') {
10193 0         0 my $left = $i;
10194             if ($char[$i+1] eq ']') {
10195 0         0 $i++;
10196 0 0       0 }
10197 0         0 while (1) {
10198             if (++$i > $#char) {
10199 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10200 0         0 }
10201             if ($char[$i] eq ']') {
10202             my $right = $i;
10203 0         0  
10204             # [^...]
10205 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10206 0         0  
10207             $i = $left;
10208             last;
10209             }
10210             }
10211             }
10212              
10213 0         0 # escape $ @ / and \
10214             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10215             $char[$i] = '\\' . $char[$i];
10216             }
10217              
10218 0         0 # rewrite character class or escape character
10219             elsif (my $char = character_class($char[$i],$modifier)) {
10220             $char[$i] = $char;
10221             }
10222              
10223 6 50       15 # /i modifier
10224 8         20 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
10225             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
10226             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
10227 8         20 }
10228             else {
10229             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
10230             }
10231             }
10232              
10233 0 0       0 # quote character before ? + * {
10234             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10235             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
10236 0         0 }
10237             else {
10238             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10239             }
10240             }
10241 0         0 }
10242 44         90  
10243 44         61 $modifier =~ tr/i//d;
10244 44         61 $delimiter = '/';
10245 44         61 $end_delimiter = '/';
10246 44         86 my $prematch = '';
10247             $prematch = "($anchor)";
10248             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10249             }
10250              
10251             #
10252             # escape regexp (s'here''b)
10253 44     44 0 316 #
10254             sub e_s1_qb {
10255             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10256 44         97  
10257             # split regexp
10258             my @char = $string =~ /\G (?>[^\\]|\\\\|[\x00-\xFF]) /oxmsg;
10259 44         162  
10260 44 50       116 # unescape character
    50          
10261             for (my $i=0; $i <= $#char; $i++) {
10262             if (0) {
10263             }
10264 98         303  
10265             # remain \\
10266             elsif ($char[$i] eq '\\\\') {
10267             }
10268              
10269 0         0 # escape $ @ / and \
10270             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10271             $char[$i] = '\\' . $char[$i];
10272             }
10273 0         0 }
10274 44         70  
10275 44         60 $delimiter = '/';
10276 44         65 $end_delimiter = '/';
10277 44         60 my $prematch = '';
10278             $prematch = q{(\G[\x00-\xFF]*?)};
10279             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10280             }
10281              
10282             #
10283             # escape regexp (s''here')
10284 44     91 0 340 #
10285             sub e_s2_q {
10286 91         172 my($ope,$delimiter,$end_delimiter,$string) = @_;
10287              
10288 91         128 $slash = 'div';
10289 91         316  
10290 91 50 66     228 my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\\\|$q_char) /oxmsg;
    50 33        
    100          
    100          
10291             for (my $i=0; $i <= $#char; $i++) {
10292             if (0) {
10293             }
10294 9         84  
10295 0         0 # escape last octet of multiple-octet
10296             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10297             $char[$i] = $1 . '\\' . $2;
10298 0         0 }
10299             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10300             $char[$i] = $1 . '\\' . $2;
10301             }
10302              
10303             # not escape \\
10304             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
10305             }
10306              
10307 0         0 # escape $ @ / and \
10308             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10309             $char[$i] = '\\' . $char[$i];
10310 5 50 66     16 }
10311 91         226 }
10312             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10313             $char[-1] = $1 . '\\' . $2;
10314 0         0 }
10315              
10316             return join '', $ope, $delimiter, @char, $end_delimiter;
10317             }
10318              
10319             #
10320             # escape regexp (s/here/and here/modifier)
10321 91     290 0 253 #
10322 290   100     2082 sub e_sub {
10323             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
10324 290         1255 $modifier ||= '';
10325 290 50       551  
10326 290         980 $modifier =~ tr/p//d;
10327 0         0 if ($modifier =~ /([adlu])/oxms) {
10328 0 0       0 my $line = 0;
10329 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10330 0         0 if ($filename ne __FILE__) {
10331             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10332             last;
10333 0         0 }
10334             }
10335             die qq{Unsupported modifier "$1" used at line $line.\n};
10336 0 100       0 }
10337 290         676  
10338 37         52 if ($variable eq '') {
10339             $variable = '$_';
10340             $bind_operator = ' =~ ';
10341 37         54 }
10342              
10343             $slash = 'div';
10344              
10345             # P.128 Start of match (or end of previous match): \G
10346             # P.130 Advanced Use of \G with Perl
10347             # in Chapter 3: Overview of Regular Expression Features and Flavors
10348             # P.312 Iterative Matching: Scalar Context, with /g
10349             # in Chapter 7: Perl
10350             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
10351              
10352             # P.181 Where You Left Off: The \G Assertion
10353             # in Chapter 5: Pattern Matching
10354             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10355              
10356             # P.220 Where You Left Off: The \G Assertion
10357             # in Chapter 5: Pattern Matching
10358 290         462 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10359 290         427  
10360             my $e_modifier = $modifier =~ tr/e//d;
10361 290         464 my $r_modifier = $modifier =~ tr/r//d;
10362 290 50       419  
10363 290         672 my $my = '';
10364 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
10365 0         0 $my = $variable;
10366             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
10367             $variable =~ s/ = .+ \z//oxms;
10368 0         0 }
10369 290         783  
10370             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
10371             $variable_basename =~ s/ \s+ \z//oxms;
10372 290         547  
10373 290 100       406 # quote replacement string
10374 290         603 my $e_replacement = '';
10375 17         33 if ($e_modifier >= 1) {
10376             $e_replacement = e_qq('', '', '', $replacement);
10377             $e_modifier--;
10378 17 100       32 }
10379 273         551 else {
10380             if ($delimiter2 eq "'") {
10381             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
10382 91         189 }
10383             else {
10384             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
10385             }
10386 182         436 }
10387              
10388             my $sub = '';
10389 290 100       515  
10390 290 100       577 # with /r
    50          
10391             if ($r_modifier) {
10392             if (0) {
10393             }
10394 8         24  
10395 0 50       0 # s///gr with multibyte anchoring
10396             elsif ($modifier =~ /g/oxms) {
10397             $sub = sprintf(
10398             # 1 2 3 4 5
10399             q,
10400              
10401             $variable, # 1
10402             ($delimiter1 eq "'") ? # 2
10403             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10404             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10405             $s_matched, # 3
10406             $e_replacement, # 4
10407             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 5
10408             );
10409             }
10410              
10411 4 0       15 # s///gr without multibyte anchoring
10412             elsif ($modifier =~ /g/oxms) {
10413             $sub = sprintf(
10414             # 1 2 3 4 5
10415             q,
10416              
10417             $variable, # 1
10418             ($delimiter1 eq "'") ? # 2
10419             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10420             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10421             $s_matched, # 3
10422             $e_replacement, # 4
10423             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 5
10424             );
10425             }
10426              
10427             # s///r
10428 0         0 else {
10429 4         5  
10430             my $prematch = q{$`};
10431 4 50       5 $prematch = q{${1}};
10432              
10433             $sub = sprintf(
10434             # 1 2 3 4 5 6 7
10435             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Ebig5hkscs::re_r=%s; %s"%s$Ebig5hkscs::re_r$'" } : %s>,
10436              
10437             $variable, # 1
10438             ($delimiter1 eq "'") ? # 2
10439             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10440             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10441             $s_matched, # 3
10442             $e_replacement, # 4
10443             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 5
10444             $prematch, # 6
10445             $variable, # 7
10446             );
10447             }
10448 4 50       21  
10449 8         22 # $var !~ s///r doesn't make sense
10450             if ($bind_operator =~ / !~ /oxms) {
10451             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
10452             }
10453             }
10454              
10455 0 100       0 # without /r
    50          
10456             else {
10457             if (0) {
10458             }
10459 282         792  
10460 0 100       0 # s///g with multibyte anchoring
    100          
10461             elsif ($modifier =~ /g/oxms) {
10462             $sub = sprintf(
10463             # 1 2 3 4 5 6 7 8 9 10
10464             q,
10465              
10466             $variable, # 1
10467             ($delimiter1 eq "'") ? # 2
10468             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10469             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10470             $s_matched, # 3
10471             $e_replacement, # 4
10472             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 5
10473             $variable, # 6
10474             $variable, # 7
10475             $variable, # 8
10476             $variable, # 9
10477              
10478             # Binary "!~" is just like "=~" except the return value is negated in the logical sense.
10479             # It returns false if the match succeeds, and true if it fails.
10480             # (and so on)
10481              
10482             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 10
10483             );
10484             }
10485              
10486 35 0       170 # s///g without multibyte anchoring
    0          
10487             elsif ($modifier =~ /g/oxms) {
10488             $sub = sprintf(
10489             # 1 2 3 4 5 6 7 8
10490             q,
10491              
10492             $variable, # 1
10493             ($delimiter1 eq "'") ? # 2
10494             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10495             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10496             $s_matched, # 3
10497             $e_replacement, # 4
10498             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 5
10499             $variable, # 6
10500             $variable, # 7
10501             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
10502             );
10503             }
10504              
10505             # s///
10506 0         0 else {
10507 247         445  
10508             my $prematch = q{$`};
10509 247 100       381 $prematch = q{${1}};
    100          
10510              
10511             $sub = sprintf(
10512              
10513             ($bind_operator =~ / =~ /oxms) ?
10514              
10515             # 1 2 3 4 5 6 7 8
10516             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Ebig5hkscs::re_r=%s; %s%s="%s$Ebig5hkscs::re_r$'"; 1 } : undef> :
10517              
10518             # 1 2 3 4 5 6 7 8
10519             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Ebig5hkscs::re_r=%s; %s%s="%s$Ebig5hkscs::re_r$'"; undef }>,
10520              
10521             $variable, # 1
10522             $bind_operator, # 2
10523             ($delimiter1 eq "'") ? # 3
10524             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10525             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10526             $s_matched, # 4
10527             $e_replacement, # 5
10528             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 6
10529             $variable, # 7
10530             $prematch, # 8
10531             );
10532             }
10533             }
10534 247 50       1104  
10535 290         925 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
10536             if ($my ne '') {
10537             $sub = "($my, $sub)[1]";
10538             }
10539 0         0  
10540 290         409 # clear s/// variable
10541             $sub_variable = '';
10542 290         424 $bind_operator = '';
10543              
10544             return $sub;
10545             }
10546              
10547             #
10548             # escape chdir (qq//, "")
10549 290     0 0 2349 #
10550             sub e_chdir {
10551 0 0       0 my($ope,$delimiter,$end_delimiter,$string) = @_;
10552 0 0       0  
10553 0 0       0 if ($^W) {
10554 0         0 if (Ebig5hkscs::_MSWin32_5Cended_path($string)) {
10555 0         0 if ($] !~ /^5\.005/oxms) {
10556             warn <
10557             @{[__FILE__]}: Can't chdir to '$string'
10558              
10559             chdir does not work with chr(0x5C) at end of path
10560             http://bugs.activestate.com/show_bug.cgi?id=81839
10561             END
10562             }
10563             }
10564 0         0 }
10565              
10566             return e_qq($ope,$delimiter,$end_delimiter,$string);
10567             }
10568              
10569             #
10570             # escape chdir (q//, '')
10571 0     2 0 0 #
10572             sub e_chdir_q {
10573 2 50       6 my($ope,$delimiter,$end_delimiter,$string) = @_;
10574 2 0       6  
10575 0 0       0 if ($^W) {
10576 0         0 if (Ebig5hkscs::_MSWin32_5Cended_path($string)) {
10577 0         0 if ($] !~ /^5\.005/oxms) {
10578             warn <
10579             @{[__FILE__]}: Can't chdir to '$string'
10580              
10581             chdir does not work with chr(0x5C) at end of path
10582             http://bugs.activestate.com/show_bug.cgi?id=81839
10583             END
10584             }
10585             }
10586 0         0 }
10587              
10588             return e_q($ope,$delimiter,$end_delimiter,$string);
10589             }
10590              
10591             #
10592             # escape regexp of split qr//
10593 2     273 0 14 #
10594 273   100     1483 sub e_split {
10595             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10596 273         1254 $modifier ||= '';
10597 273 50       589  
10598 273         1156 $modifier =~ tr/p//d;
10599 0         0 if ($modifier =~ /([adlu])/oxms) {
10600 0 0       0 my $line = 0;
10601 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10602 0         0 if ($filename ne __FILE__) {
10603             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10604             last;
10605 0         0 }
10606             }
10607             die qq{Unsupported modifier "$1" used at line $line.\n};
10608 0         0 }
10609              
10610             $slash = 'div';
10611 273 100       484  
10612 273         564 # /b /B modifier
10613             if ($modifier =~ tr/bB//d) {
10614             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10615 84 100       414 }
10616 189         584  
10617             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10618             my $metachar = qr/[\@\\|[\]{^]/oxms;
10619 189         766  
10620             # split regexp
10621             my @char = $string =~ /\G((?>
10622             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
10623             \\x (?>[0-9A-Fa-f]{1,2}) |
10624             \\ (?>[0-7]{2,3}) |
10625             \\c [\x40-\x5F] |
10626             \\x\{ (?>[0-9A-Fa-f]+) \} |
10627             \\o\{ (?>[0-7]+) \} |
10628             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
10629             \\ $q_char |
10630             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
10631             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
10632             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
10633             [\$\@] $qq_variable |
10634             \$ (?>\s* [0-9]+) |
10635             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
10636             \$ \$ (?![\w\{]) |
10637             \$ (?>\s*) \$ (?>\s*) $qq_variable |
10638             \[\^ |
10639             \[\: (?>[a-z]+) :\] |
10640             \[\:\^ (?>[a-z]+) :\] |
10641             \(\? |
10642             $q_char
10643 189         16660 ))/oxmsg;
10644 189         616  
10645 189         289 my $left_e = 0;
10646             my $right_e = 0;
10647             for (my $i=0; $i <= $#char; $i++) {
10648 189 50 33     604  
    50 33        
    100          
    100          
    50          
    50          
10649 372         4037 # "\L\u" --> "\u\L"
10650             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
10651             @char[$i,$i+1] = @char[$i+1,$i];
10652             }
10653              
10654 0         0 # "\U\l" --> "\l\U"
10655             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
10656             @char[$i,$i+1] = @char[$i+1,$i];
10657             }
10658              
10659 0         0 # octal escape sequence
10660             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
10661             $char[$i] = Ebig5hkscs::octchr($1);
10662             }
10663              
10664 1         3 # hexadecimal escape sequence
10665             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
10666             $char[$i] = Ebig5hkscs::hexchr($1);
10667             }
10668              
10669             # \b{...} --> b\{...}
10670             # \B{...} --> B\{...}
10671             # \N{CHARNAME} --> N\{CHARNAME}
10672             # \p{PROPERTY} --> p\{PROPERTY}
10673 1         5 # \P{PROPERTY} --> P\{PROPERTY}
10674             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
10675             $char[$i] = $1 . '\\' . $2;
10676             }
10677              
10678 0         0 # \p, \P, \X --> p, P, X
10679             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
10680             $char[$i] = $1;
10681 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          
10682              
10683             if (0) {
10684             }
10685 372         4211  
10686 0         0 # escape last octet of multiple-octet
10687             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10688             $char[$i] = $1 . '\\' . $2;
10689             }
10690              
10691 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
10692 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
10693             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)) {
10694             $char[$i] .= join '', splice @char, $i+1, 3;
10695 0         0 }
10696             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)) {
10697             $char[$i] .= join '', splice @char, $i+1, 2;
10698 0         0 }
10699             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)) {
10700             $char[$i] .= join '', splice @char, $i+1, 1;
10701             }
10702             }
10703              
10704 0         0 # open character class [...]
10705 3 50       8 elsif ($char[$i] eq '[') {
10706 3         11 my $left = $i;
10707             if ($char[$i+1] eq ']') {
10708 0         0 $i++;
10709 3 50       6 }
10710 7         16 while (1) {
10711             if (++$i > $#char) {
10712 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10713 7         15 }
10714             if ($char[$i] eq ']') {
10715             my $right = $i;
10716 3 50       5  
10717 3         35 # [...]
  0         0  
10718             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10719             splice @char, $left, $right-$left+1, sprintf(q{@{[Ebig5hkscs::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10720 0         0 }
10721             else {
10722             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
10723 3         20 }
10724 3         6  
10725             $i = $left;
10726             last;
10727             }
10728             }
10729             }
10730              
10731 3         9 # open character class [^...]
10732 1 50       3 elsif ($char[$i] eq '[^') {
10733 1         4 my $left = $i;
10734             if ($char[$i+1] eq ']') {
10735 0         0 $i++;
10736 1 50       1 }
10737 2         6 while (1) {
10738             if (++$i > $#char) {
10739 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10740 2         4 }
10741             if ($char[$i] eq ']') {
10742             my $right = $i;
10743 1 50       2  
10744 1         7 # [^...]
  0         0  
10745             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10746             splice @char, $left, $right-$left+1, sprintf(q{@{[Ebig5hkscs::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10747 0         0 }
10748             else {
10749             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10750 1         13 }
10751 1         3  
10752             $i = $left;
10753             last;
10754             }
10755             }
10756             }
10757              
10758 1         3 # rewrite character class or escape character
10759             elsif (my $char = character_class($char[$i],$modifier)) {
10760             $char[$i] = $char;
10761             }
10762              
10763             # P.794 29.2.161. split
10764             # in Chapter 29: Functions
10765             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10766              
10767             # P.951 split
10768             # in Chapter 27: Functions
10769             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10770              
10771             # said "The //m modifier is assumed when you split on the pattern /^/",
10772             # but perl5.008 is not so. Therefore, this software adds //m.
10773             # (and so on)
10774              
10775 5         22 # split(m/^/) --> split(m/^/m)
10776             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
10777             $modifier .= 'm';
10778             }
10779              
10780 11 50       43 # /i modifier
10781 18         40 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
10782             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
10783             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
10784 18         65 }
10785             else {
10786             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
10787             }
10788             }
10789              
10790 0 50       0 # \u \l \U \L \F \Q \E
10791 2         9 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
10792             if ($right_e < $left_e) {
10793             $char[$i] = '\\' . $char[$i];
10794             }
10795 0         0 }
10796 0         0 elsif ($char[$i] eq '\u') {
10797             $char[$i] = '@{[Ebig5hkscs::ucfirst qq<';
10798             $left_e++;
10799 0         0 }
10800 0         0 elsif ($char[$i] eq '\l') {
10801             $char[$i] = '@{[Ebig5hkscs::lcfirst qq<';
10802             $left_e++;
10803 0         0 }
10804 0         0 elsif ($char[$i] eq '\U') {
10805             $char[$i] = '@{[Ebig5hkscs::uc qq<';
10806             $left_e++;
10807 0         0 }
10808 0         0 elsif ($char[$i] eq '\L') {
10809             $char[$i] = '@{[Ebig5hkscs::lc qq<';
10810             $left_e++;
10811 0         0 }
10812 0         0 elsif ($char[$i] eq '\F') {
10813             $char[$i] = '@{[Ebig5hkscs::fc qq<';
10814             $left_e++;
10815 0         0 }
10816 0         0 elsif ($char[$i] eq '\Q') {
10817             $char[$i] = '@{[CORE::quotemeta qq<';
10818             $left_e++;
10819 0 0       0 }
10820 0         0 elsif ($char[$i] eq '\E') {
10821 0         0 if ($right_e < $left_e) {
10822             $char[$i] = '>]}';
10823             $right_e++;
10824 0         0 }
10825             else {
10826             $char[$i] = '';
10827             }
10828 0         0 }
10829 0 0       0 elsif ($char[$i] eq '\Q') {
10830 0         0 while (1) {
10831             if (++$i > $#char) {
10832 0 0       0 last;
10833 0         0 }
10834             if ($char[$i] eq '\E') {
10835             last;
10836             }
10837             }
10838             }
10839             elsif ($char[$i] eq '\E') {
10840             }
10841              
10842 0 0       0 # $0 --> $0
10843 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
10844             if ($ignorecase) {
10845             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10846             }
10847 0 0       0 }
10848 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
10849             if ($ignorecase) {
10850             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10851             }
10852             }
10853              
10854             # $$ --> $$
10855             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10856             }
10857              
10858             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10859 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
10860 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10861 0         0 $char[$i] = e_capture($1);
10862             if ($ignorecase) {
10863             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10864             }
10865 0         0 }
10866 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10867 0         0 $char[$i] = e_capture($1);
10868             if ($ignorecase) {
10869             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10870             }
10871             }
10872              
10873 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10874 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) {
10875 0         0 $char[$i] = e_capture($1.'->'.$2);
10876             if ($ignorecase) {
10877             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10878             }
10879             }
10880              
10881 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10882 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) {
10883 0         0 $char[$i] = e_capture($1.'->'.$2);
10884             if ($ignorecase) {
10885             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10886             }
10887             }
10888              
10889 0         0 # $$foo
10890 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10891 0         0 $char[$i] = e_capture($1);
10892             if ($ignorecase) {
10893             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10894             }
10895             }
10896              
10897 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
10898 12         37 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10899             if ($ignorecase) {
10900             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::PREMATCH())]}';
10901 0         0 }
10902             else {
10903             $char[$i] = '@{[Ebig5hkscs::PREMATCH()]}';
10904             }
10905             }
10906              
10907 12 50       61 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
10908 12         43 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10909             if ($ignorecase) {
10910             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::MATCH())]}';
10911 0         0 }
10912             else {
10913             $char[$i] = '@{[Ebig5hkscs::MATCH()]}';
10914             }
10915             }
10916              
10917 12 50       68 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
10918 9         25 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10919             if ($ignorecase) {
10920             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::POSTMATCH())]}';
10921 0         0 }
10922             else {
10923             $char[$i] = '@{[Ebig5hkscs::POSTMATCH()]}';
10924             }
10925             }
10926              
10927 9 0       50 # ${ foo }
10928 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) {
10929             if ($ignorecase) {
10930             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $1 . ')]}';
10931             }
10932             }
10933              
10934 0         0 # ${ ... }
10935 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10936 0         0 $char[$i] = e_capture($1);
10937             if ($ignorecase) {
10938             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10939             }
10940             }
10941              
10942 0         0 # $scalar or @array
10943 3 50       10 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10944 3         17 $char[$i] = e_string($char[$i]);
10945             if ($ignorecase) {
10946             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10947             }
10948             }
10949              
10950 0 100       0 # quote character before ? + * {
10951             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10952             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10953 7         51 }
10954             else {
10955             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10956             }
10957             }
10958             }
10959 4         22  
10960 189 50       608 # make regexp string
10961 189         453 $modifier =~ tr/i//d;
10962             if ($left_e > $right_e) {
10963 0         0 return join '', 'Ebig5hkscs::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
10964             }
10965             return join '', 'Ebig5hkscs::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
10966             }
10967              
10968             #
10969             # escape regexp of split qr''
10970 189     112 0 1759 #
10971 112   100     1036 sub e_split_q {
10972             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10973 112         360 $modifier ||= '';
10974 112 50       269  
10975 112         356 $modifier =~ tr/p//d;
10976 0         0 if ($modifier =~ /([adlu])/oxms) {
10977 0 0       0 my $line = 0;
10978 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10979 0         0 if ($filename ne __FILE__) {
10980             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10981             last;
10982 0         0 }
10983             }
10984             die qq{Unsupported modifier "$1" used at line $line.\n};
10985 0         0 }
10986              
10987             $slash = 'div';
10988 112 100       311  
10989 112         413 # /b /B modifier
10990             if ($modifier =~ tr/bB//d) {
10991             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10992 56 100       316 }
10993              
10994             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10995 56         154  
10996             # split regexp
10997             my @char = $string =~ /\G((?>
10998             [^\x81-\xFE\\\[] |
10999             [\x81-\xFE][\x00-\xFF] |
11000             \[\^ |
11001             \[\: (?>[a-z]+) \:\] |
11002             \[\:\^ (?>[a-z]+) \:\] |
11003             \\ (?:$q_char) |
11004             (?:$q_char)
11005             ))/oxmsg;
11006 56         516  
11007 56 50 33     188 # unescape character
    50 100        
    50 66        
    50 33        
    50          
    100          
    50          
11008             for (my $i=0; $i <= $#char; $i++) {
11009             if (0) {
11010             }
11011 56         567  
11012 0         0 # escape last octet of multiple-octet
11013             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
11014             $char[$i] = $1 . '\\' . $2;
11015             }
11016              
11017 0         0 # open character class [...]
11018 0 0       0 elsif ($char[$i] eq '[') {
11019 0         0 my $left = $i;
11020             if ($char[$i+1] eq ']') {
11021 0         0 $i++;
11022 0 0       0 }
11023 0         0 while (1) {
11024             if (++$i > $#char) {
11025 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11026 0         0 }
11027             if ($char[$i] eq ']') {
11028             my $right = $i;
11029 0         0  
11030             # [...]
11031 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
11032 0         0  
11033             $i = $left;
11034             last;
11035             }
11036             }
11037             }
11038              
11039 0         0 # open character class [^...]
11040 0 0       0 elsif ($char[$i] eq '[^') {
11041 0         0 my $left = $i;
11042             if ($char[$i+1] eq ']') {
11043 0         0 $i++;
11044 0 0       0 }
11045 0         0 while (1) {
11046             if (++$i > $#char) {
11047 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11048 0         0 }
11049             if ($char[$i] eq ']') {
11050             my $right = $i;
11051 0         0  
11052             # [^...]
11053 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
11054 0         0  
11055             $i = $left;
11056             last;
11057             }
11058             }
11059             }
11060              
11061 0         0 # rewrite character class or escape character
11062             elsif (my $char = character_class($char[$i],$modifier)) {
11063             $char[$i] = $char;
11064             }
11065              
11066 0         0 # split(m/^/) --> split(m/^/m)
11067             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
11068             $modifier .= 'm';
11069             }
11070              
11071 0 50       0 # /i modifier
11072 12         35 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
11073             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
11074             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
11075 12         32 }
11076             else {
11077             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
11078             }
11079             }
11080              
11081 0 0       0 # quote character before ? + * {
11082             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
11083             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
11084 0         0 }
11085             else {
11086             $char[$i-1] = '(?:' . $char[$i-1] . ')';
11087             }
11088             }
11089 0         0 }
11090 56         121  
11091             $modifier =~ tr/i//d;
11092             return join '', 'Ebig5hkscs::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
11093             }
11094              
11095             #
11096             # escape use without import
11097 56     0 0 309 #
11098             sub e_use_noimport {
11099 0           my($module) = @_;
11100              
11101 0           my $expr = _pathof($module);
11102 0            
11103             my $fh = gensym();
11104 0 0         for my $realfilename (_realfilename($expr)) {
11105 0            
11106 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11107 0 0         local $/ = undef; # slurp mode
11108             my $script = <$fh>;
11109 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11110 0            
11111             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11112 0           return qq;
11113             }
11114             last;
11115             }
11116 0           }
11117              
11118             return qq;
11119             }
11120              
11121             #
11122             # escape no without unimport
11123 0     0 0   #
11124             sub e_no_nounimport {
11125 0           my($module) = @_;
11126              
11127 0           my $expr = _pathof($module);
11128 0            
11129             my $fh = gensym();
11130 0 0         for my $realfilename (_realfilename($expr)) {
11131 0            
11132 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11133 0 0         local $/ = undef; # slurp mode
11134             my $script = <$fh>;
11135 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11136 0            
11137             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11138 0           return qq;
11139             }
11140             last;
11141             }
11142 0           }
11143              
11144             return qq;
11145             }
11146              
11147             #
11148             # escape use with import no parameter
11149 0     0 0   #
11150             sub e_use_noparam {
11151 0           my($module) = @_;
11152              
11153 0           my $expr = _pathof($module);
11154 0            
11155             my $fh = gensym();
11156 0 0         for my $realfilename (_realfilename($expr)) {
11157 0            
11158 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11159 0 0         local $/ = undef; # slurp mode
11160             my $script = <$fh>;
11161 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11162              
11163             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11164              
11165             # P.326 UNIVERSAL: The Ultimate Ancestor Class
11166             # in Chapter 12: Objects
11167             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
11168              
11169             # P.435 UNIVERSAL: The Ultimate Ancestor Class
11170             # in Chapter 12: Objects
11171             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
11172              
11173 0           # (and so on)
11174              
11175 0           return qq[BEGIN { Ebig5hkscs::require '$expr'; $module->import() if $module->can('import'); }];
11176             }
11177             last;
11178             }
11179 0           }
11180              
11181             return qq;
11182             }
11183              
11184             #
11185             # escape no with unimport no parameter
11186 0     0 0   #
11187             sub e_no_noparam {
11188 0           my($module) = @_;
11189              
11190 0           my $expr = _pathof($module);
11191 0            
11192             my $fh = gensym();
11193 0 0         for my $realfilename (_realfilename($expr)) {
11194 0            
11195 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11196 0 0         local $/ = undef; # slurp mode
11197             my $script = <$fh>;
11198 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11199 0            
11200             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11201 0           return qq[BEGIN { Ebig5hkscs::require '$expr'; $module->unimport() if $module->can('unimport'); }];
11202             }
11203             last;
11204             }
11205 0           }
11206              
11207             return qq;
11208             }
11209              
11210             #
11211             # escape use with import parameters
11212 0     0 0   #
11213             sub e_use {
11214 0           my($module,$list) = @_;
11215              
11216 0           my $expr = _pathof($module);
11217 0            
11218             my $fh = gensym();
11219 0 0         for my $realfilename (_realfilename($expr)) {
11220 0            
11221 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11222 0 0         local $/ = undef; # slurp mode
11223             my $script = <$fh>;
11224 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11225 0            
11226             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11227 0           return qq[BEGIN { Ebig5hkscs::require '$expr'; $module->import($list) if $module->can('import'); }];
11228             }
11229             last;
11230             }
11231 0           }
11232              
11233             return qq;
11234             }
11235              
11236             #
11237             # escape no with unimport parameters
11238 0     0 0   #
11239             sub e_no {
11240 0           my($module,$list) = @_;
11241              
11242 0           my $expr = _pathof($module);
11243 0            
11244             my $fh = gensym();
11245 0 0         for my $realfilename (_realfilename($expr)) {
11246 0            
11247 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11248 0 0         local $/ = undef; # slurp mode
11249             my $script = <$fh>;
11250 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11251 0            
11252             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11253 0           return qq[BEGIN { Ebig5hkscs::require '$expr'; $module->unimport($list) if $module->can('unimport'); }];
11254             }
11255             last;
11256             }
11257 0           }
11258              
11259             return qq;
11260             }
11261              
11262             #
11263             # file path of module
11264 0     0     #
11265             sub _pathof {
11266 0 0         my($expr) = @_;
11267 0            
11268             if ($^O eq 'MacOS') {
11269             $expr =~ s#::#:#g;
11270 0           }
11271             else {
11272 0 0         $expr =~ s#::#/#g;
11273             }
11274 0           $expr .= '.pm' if $expr !~ / \.pm \z/oxmsi;
11275              
11276             return $expr;
11277             }
11278              
11279             #
11280             # real file name of module
11281 0     0     #
11282             sub _realfilename {
11283 0 0         my($expr) = @_;
11284 0            
  0            
11285             if ($^O eq 'MacOS') {
11286             return map {"$_$expr"} @INC;
11287 0           }
  0            
11288             else {
11289             return map {"$_/$expr"} @INC;
11290             }
11291             }
11292              
11293             #
11294             # instead of Carp::carp
11295 0     0 0   #
11296 0           sub carp {
11297             my($package,$filename,$line) = caller(1);
11298             print STDERR "@_ at $filename line $line.\n";
11299             }
11300              
11301             #
11302             # instead of Carp::croak
11303 0     0 0   #
11304 0           sub croak {
11305 0           my($package,$filename,$line) = caller(1);
11306             print STDERR "@_ at $filename line $line.\n";
11307             die "\n";
11308             }
11309              
11310             #
11311             # instead of Carp::cluck
11312 0     0 0   #
11313 0           sub cluck {
11314 0           my $i = 0;
11315 0           my @cluck = ();
11316 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11317             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
11318 0           $i++;
11319 0           }
11320 0           print STDERR CORE::reverse @cluck;
11321             print STDERR "\n";
11322             print STDERR @_;
11323             }
11324              
11325             #
11326             # instead of Carp::confess
11327 0     0 0   #
11328 0           sub confess {
11329 0           my $i = 0;
11330 0           my @confess = ();
11331 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11332             push @confess, "[$i] $filename($line) $package::$subroutine\n";
11333 0           $i++;
11334 0           }
11335 0           print STDERR CORE::reverse @confess;
11336 0           print STDERR "\n";
11337             print STDERR @_;
11338             die "\n";
11339             }
11340              
11341             1;
11342              
11343             __END__