File Coverage

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


line stmt bran cond sub pod time code
1             package Ebig5hkscs;
2 389     389   12608 use strict;
  389         2014  
  389         16528  
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   8343 use 5.00503; # Galapagos Consensus 1998 for primetools
  389         2653  
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   3796 use vars qw($VERSION);
  389         3155  
  389         63676  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 389 50   389   6709 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 389         801 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 389         54590 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   30410 CORE::eval q{
  389     389   5726  
  389     130   3852  
  389         50615  
  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       179773 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0 0   0 0 0 if ($] < 5.006) {
69 0         0 return \do { local *_ };
  0         0  
70             }
71             else {
72 0         0 return undef;
73             }
74             }
75              
76             sub qualify ($$) {
77 0     1152 0 0 my($name) = @_;
78              
79 1152 50       2950 if (ref $name) {
    50          
    50          
    50          
    50          
    50          
    50          
80 1152         4832 return $name;
81             }
82             elsif (Ebig5hkscs::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Ebig5hkscs::index($name,"'") >= 0) {
86 0         0 return $name;
87             }
88              
89             # special character, "^xyz"
90             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
91              
92             # RGS 2001-11-05 : translate leading ^X to control-char
93 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
94 0         0 return 'main::' . $name;
95             }
96              
97             # Global names
98             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             # or other
103             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
104 0         0 return 'main::' . $name;
105             }
106              
107             elsif (defined $_[1]) {
108 0         0 return $_[1] . '::' . $name;
109             }
110             else {
111 1152         9185 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 50   1152 0 0 if (defined $_[1]) {
117 389     389   6069 no strict qw(refs);
  389         2663  
  389         32095  
118 1152         4111 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 389     389   2391 no strict qw(refs);
  389     0   3925  
  389         76693  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  1152         1960  
123             }
124             }
125             }
126              
127             # P.714 29.2.39. flock
128             # in Chapter 29: Functions
129             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
130              
131             # P.863 flock
132             # in Chapter 27: Functions
133             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
134              
135             sub LOCK_SH() {1}
136             sub LOCK_EX() {2}
137             sub LOCK_UN() {8}
138             sub LOCK_NB() {4}
139              
140             # instead of Carp.pm
141             sub carp;
142             sub croak;
143             sub cluck;
144             sub confess;
145              
146             # 6.18. Matching Multiple-Byte Characters
147             # in Chapter 6. Pattern Matching
148             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
149             # (and so on)
150              
151             # regexp of character
152             my $your_char = q{[\x81-\xFE][\x00-\xFF]|[\x00-\xFF]};
153 389     389   4282 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  389         3804  
  389         36324  
154 389     389   2369 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  389         2147  
  389         631316  
155              
156             #
157             # Big5-HKSCS character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # Big5-HKSCS case conversion
163             #
164             my %lc = ();
165             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
166             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
167             my %uc = ();
168             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
169             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
170             my %fc = ();
171             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
172             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
173              
174             if (0) {
175             }
176              
177             elsif (__PACKAGE__ =~ / \b Ebig5hkscs \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0x80],
180             [0xFF..0xFF],
181             ],
182             2 => [ [0x81..0xFE],[0x40..0x7E],
183             [0x81..0xFE],[0xA1..0xFE],
184             ],
185             );
186             }
187              
188             else {
189             croak "Don't know my package name '@{[__PACKAGE__]}'";
190             }
191              
192             #
193             # @ARGV wildcard globbing
194             #
195             sub import {
196              
197 1152 50   5   5977 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
198 5         84 my @argv = ();
199 0         0 for (@ARGV) {
200              
201             # has space
202 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
203 0 0       0 if (my @glob = Ebig5hkscs::glob(qq{"$_"})) {
204 0         0 push @argv, @glob;
205             }
206             else {
207 0         0 push @argv, $_;
208             }
209             }
210              
211             # has wildcard metachar
212             elsif (/\A (?:$q_char)*? [*?] /oxms) {
213 0 0       0 if (my @glob = Ebig5hkscs::glob($_)) {
214 0         0 push @argv, @glob;
215             }
216             else {
217 0         0 push @argv, $_;
218             }
219             }
220              
221             # no wildcard globbing
222             else {
223 0         0 push @argv, $_;
224             }
225             }
226 0         0 @ARGV = @argv;
227             }
228              
229 0         0 *Char::ord = \&Big5HKSCS::ord;
230 5         27 *Char::ord_ = \&Big5HKSCS::ord_;
231 5         13 *Char::reverse = \&Big5HKSCS::reverse;
232 5         11 *Char::getc = \&Big5HKSCS::getc;
233 5         12 *Char::length = \&Big5HKSCS::length;
234 5         10 *Char::substr = \&Big5HKSCS::substr;
235 5         12 *Char::index = \&Big5HKSCS::index;
236 5         10 *Char::rindex = \&Big5HKSCS::rindex;
237 5         11 *Char::eval = \&Big5HKSCS::eval;
238 5         35 *Char::escape = \&Big5HKSCS::escape;
239 5         11 *Char::escape_token = \&Big5HKSCS::escape_token;
240 5         10 *Char::escape_script = \&Big5HKSCS::escape_script;
241             }
242              
243             # P.230 Care with Prototypes
244             # in Chapter 6: Subroutines
245             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
246             #
247             # If you aren't careful, you can get yourself into trouble with prototypes.
248             # But if you are careful, you can do a lot of neat things with them. This is
249             # all very powerful, of course, and should only be used in moderation to make
250             # the world a better place.
251              
252             # P.332 Care with Prototypes
253             # in Chapter 7: Subroutines
254             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
255             #
256             # If you aren't careful, you can get yourself into trouble with prototypes.
257             # But if you are careful, you can do a lot of neat things with them. This is
258             # all very powerful, of course, and should only be used in moderation to make
259             # the world a better place.
260              
261             #
262             # Prototypes of subroutines
263             #
264       0     sub unimport {}
265             sub Ebig5hkscs::split(;$$$);
266             sub Ebig5hkscs::tr($$$$;$);
267             sub Ebig5hkscs::chop(@);
268             sub Ebig5hkscs::index($$;$);
269             sub Ebig5hkscs::rindex($$;$);
270             sub Ebig5hkscs::lcfirst(@);
271             sub Ebig5hkscs::lcfirst_();
272             sub Ebig5hkscs::lc(@);
273             sub Ebig5hkscs::lc_();
274             sub Ebig5hkscs::ucfirst(@);
275             sub Ebig5hkscs::ucfirst_();
276             sub Ebig5hkscs::uc(@);
277             sub Ebig5hkscs::uc_();
278             sub Ebig5hkscs::fc(@);
279             sub Ebig5hkscs::fc_();
280             sub Ebig5hkscs::ignorecase;
281             sub Ebig5hkscs::classic_character_class;
282             sub Ebig5hkscs::capture;
283             sub Ebig5hkscs::chr(;$);
284             sub Ebig5hkscs::chr_();
285             sub Ebig5hkscs::filetest;
286             sub Ebig5hkscs::r(;*@);
287             sub Ebig5hkscs::w(;*@);
288             sub Ebig5hkscs::x(;*@);
289             sub Ebig5hkscs::o(;*@);
290             sub Ebig5hkscs::R(;*@);
291             sub Ebig5hkscs::W(;*@);
292             sub Ebig5hkscs::X(;*@);
293             sub Ebig5hkscs::O(;*@);
294             sub Ebig5hkscs::e(;*@);
295             sub Ebig5hkscs::z(;*@);
296             sub Ebig5hkscs::s(;*@);
297             sub Ebig5hkscs::f(;*@);
298             sub Ebig5hkscs::d(;*@);
299             sub Ebig5hkscs::l(;*@);
300             sub Ebig5hkscs::p(;*@);
301             sub Ebig5hkscs::S(;*@);
302             sub Ebig5hkscs::b(;*@);
303             sub Ebig5hkscs::c(;*@);
304             sub Ebig5hkscs::u(;*@);
305             sub Ebig5hkscs::g(;*@);
306             sub Ebig5hkscs::k(;*@);
307             sub Ebig5hkscs::T(;*@);
308             sub Ebig5hkscs::B(;*@);
309             sub Ebig5hkscs::M(;*@);
310             sub Ebig5hkscs::A(;*@);
311             sub Ebig5hkscs::C(;*@);
312             sub Ebig5hkscs::filetest_;
313             sub Ebig5hkscs::r_();
314             sub Ebig5hkscs::w_();
315             sub Ebig5hkscs::x_();
316             sub Ebig5hkscs::o_();
317             sub Ebig5hkscs::R_();
318             sub Ebig5hkscs::W_();
319             sub Ebig5hkscs::X_();
320             sub Ebig5hkscs::O_();
321             sub Ebig5hkscs::e_();
322             sub Ebig5hkscs::z_();
323             sub Ebig5hkscs::s_();
324             sub Ebig5hkscs::f_();
325             sub Ebig5hkscs::d_();
326             sub Ebig5hkscs::l_();
327             sub Ebig5hkscs::p_();
328             sub Ebig5hkscs::S_();
329             sub Ebig5hkscs::b_();
330             sub Ebig5hkscs::c_();
331             sub Ebig5hkscs::u_();
332             sub Ebig5hkscs::g_();
333             sub Ebig5hkscs::k_();
334             sub Ebig5hkscs::T_();
335             sub Ebig5hkscs::B_();
336             sub Ebig5hkscs::M_();
337             sub Ebig5hkscs::A_();
338             sub Ebig5hkscs::C_();
339             sub Ebig5hkscs::glob($);
340             sub Ebig5hkscs::glob_();
341             sub Ebig5hkscs::lstat(*);
342             sub Ebig5hkscs::lstat_();
343             sub Ebig5hkscs::opendir(*$);
344             sub Ebig5hkscs::stat(*);
345             sub Ebig5hkscs::stat_();
346             sub Ebig5hkscs::unlink(@);
347             sub Ebig5hkscs::chdir(;$);
348             sub Ebig5hkscs::do($);
349             sub Ebig5hkscs::require(;$);
350             sub Ebig5hkscs::telldir(*);
351              
352             sub Big5HKSCS::ord(;$);
353             sub Big5HKSCS::ord_();
354             sub Big5HKSCS::reverse(@);
355             sub Big5HKSCS::getc(;*@);
356             sub Big5HKSCS::length(;$);
357             sub Big5HKSCS::substr($$;$$);
358             sub Big5HKSCS::index($$;$);
359             sub Big5HKSCS::rindex($$;$);
360             sub Big5HKSCS::escape(;$);
361              
362             #
363             # Regexp work
364             #
365 389         43893 use vars qw(
366             $re_a
367             $re_t
368             $re_n
369             $re_r
370 389     389   3138 );
  389         2279  
371              
372             #
373             # Character class
374             #
375 389         131938 use vars qw(
376             $dot
377             $dot_s
378             $eD
379             $eS
380             $eW
381             $eH
382             $eV
383             $eR
384             $eN
385             $not_alnum
386             $not_alpha
387             $not_ascii
388             $not_blank
389             $not_cntrl
390             $not_digit
391             $not_graph
392             $not_lower
393             $not_lower_i
394             $not_print
395             $not_punct
396             $not_space
397             $not_upper
398             $not_upper_i
399             $not_word
400             $not_xdigit
401             $eb
402             $eB
403 389     389   2766 );
  389         3619  
404              
405 389         4856191 use vars qw(
406             $anchor
407             $matched
408 389     389   3899 );
  389         725  
409             ${Ebig5hkscs::anchor} = qr{\G(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?}oxms;
410             my $q_char_SADAHIRO_Tomoyuki_2002_01_17 = '';
411              
412             # Quantifiers
413             # {n,m} --- Match at least n but not more than m times
414             #
415             # n and m are limited to non-negative integral values less than a
416             # preset limit defined when perl is built. This is usually 32766 on
417             # the most common platforms.
418             #
419             # The following code is an attempt to solve the above limitations
420             # in a multi-byte anchoring.
421              
422             # avoid "Segmentation fault" and "Error: Parse exception"
423              
424             # perl5101delta
425             # http://perldoc.perl.org/perl5101delta.html
426             # In 5.10.0, the * quantifier in patterns was sometimes treated as {0,32767}
427             # [RT #60034, #60464]. For example, this match would fail:
428             # ("ab" x 32768) =~ /^(ab)*$/
429              
430             # SEE ALSO
431             #
432             # Complex regular subexpression recursion limit
433             # http://www.perlmonks.org/?node_id=810857
434             #
435             # regexp iteration limits
436             # http://www.nntp.perl.org/group/perl.perl5.porters/2009/02/msg144065.html
437             #
438             # latest Perl won't match certain regexes more than 32768 characters long
439             # http://stackoverflow.com/questions/26226630/latest-perl-wont-match-certain-regexes-more-than-32768-characters-long
440             #
441             # Break through the limitations of regular expressions of Perl
442             # http://d.hatena.ne.jp/gfx/20110212/1297512479
443              
444             if (($] >= 5.010001) or
445             # ActivePerl 5.6 or later (include 5.10.0)
446             (defined($ActivePerl::VERSION) and ($ActivePerl::VERSION > 800)) or
447             (($^O eq 'MSWin32') and ($] =~ /\A 5\.006/oxms))
448             ) {
449             my $sbcs = ''; # Single Byte Character Set
450             for my $range (@{ $range_tr{1} }) {
451             $sbcs .= sprintf('\\x%02X-\\x%02X', $range->[0], $range->[-1]);
452             }
453              
454             if (0) {
455             }
456              
457             # other encoding
458             else {
459             ${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[$sbcs](?:[^$sbcs][^$sbcs])*?}oxms;
460             # ******* octets not in multiple octet char (always char boundary)
461             # **************** 2 octet chars
462             }
463              
464             ${Ebig5hkscs::anchor_SADAHIRO_Tomoyuki_2002_01_17} =
465             qr{\G(?(?=.{0,32766}\z)(?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?|(?(?=[$sbcs]+\z).*?|(?:${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17})))}oxms;
466             # qr{
467             # \G # (1), (2)
468             # (? # (3)
469             # (?=.{0,32766}\z) # (4)
470             # (?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?| # (5)
471             # (?(?=[$sbcs]+\z) # (6)
472             # .*?| #(7)
473             # (?:${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17}) # (8)
474             # ))}oxms;
475              
476             # avoid: Complex regular subexpression recursion limit (32766) exceeded at here.
477             local $^W = 0;
478              
479             if (((('A' x 32768).'B') !~ / ${Ebig5hkscs::anchor} B /oxms) and
480             ((('A' x 32768).'B') =~ / ${Ebig5hkscs::anchor_SADAHIRO_Tomoyuki_2002_01_17} B /oxms)
481             ) {
482             ${Ebig5hkscs::anchor} = ${Ebig5hkscs::anchor_SADAHIRO_Tomoyuki_2002_01_17};
483             }
484             else {
485             undef ${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17};
486             }
487             }
488              
489             # (1)
490             # P.128 Start of match (or end of previous match): \G
491             # P.130 Advanced Use of \G with Perl
492             # in Chapter3: Over view of Regular Expression Features and Flavors
493             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
494              
495             # (2)
496             # P.255 Use leading anchors
497             # P.256 Expose ^ and \G at the front of expressions
498             # in Chapter6: Crafting an Efficient Expression
499             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
500              
501             # (3)
502             # P.138 Conditional: (? if then| else)
503             # in Chapter3: Over view of Regular Expression Features and Flavors
504             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
505              
506             # (4)
507             # perlre
508             # http://perldoc.perl.org/perlre.html
509             # The "*" quantifier is equivalent to {0,} , the "+" quantifier to {1,} ,
510             # and the "?" quantifier to {0,1}, ., n, and m are limited to non-negative
511             # integral values less than a preset limit defined when perl is built.
512             # This is usually 32766 on the most common platforms. The actual limit
513             # can be seen in the error message generated by code such as this:
514             # $_ **= $_ , / {$_} / for 2 .. 42;
515              
516             # (5)
517             # P.1023 Multiple-Byte Anchoring
518             # in Appendix W Perl Code Examples
519             # of ISBN 1-56592-224-7 CJKV Information Processing
520              
521             # (6)
522             # if string has only SBCS (Single Byte Character Set)
523              
524             # (7)
525             # then .*? (isn't limited to 32766)
526              
527             # (8)
528             # else Big5-HKSCS::Regexp::Const (SADAHIRO Tomoyuki)
529             # http://homepage1.nifty.com/nomenclator/perl/shiftjis.htm#long
530             # http://search.cpan.org/~sadahiro/Big5-HKSCS-Regexp/
531             # $PadA = ' (?:\A| [\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
532             # $PadG = '\G(?: |[\x00-\xFF]*?[\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
533             # $PadGA = '\G(?:\A|(?:[\x81-\xFE]{2})+?|[\x00-\xFF]*?[\x00-\x80\xA0-\xDF] (?:[\x81-\xFE]{2})*?)';
534              
535             ${Ebig5hkscs::dot} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
536             ${Ebig5hkscs::dot_s} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])};
537             ${Ebig5hkscs::eD} = qr{(?>[^\x81-\xFE0-9]|[\x81-\xFE][\x00-\xFF])};
538              
539             # Vertical tabs are now whitespace
540             # \s in a regex now matches a vertical tab in all circumstances.
541             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
542             # ${Ebig5hkscs::eS} = qr{(?>[^\x81-\xFE\x09\x0A \x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
543             # ${Ebig5hkscs::eS} = qr{(?>[^\x81-\xFE\x09\x0A\x0B\x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
544             ${Ebig5hkscs::eS} = qr{(?>[^\x81-\xFE\s]|[\x81-\xFE][\x00-\xFF])};
545              
546             ${Ebig5hkscs::eW} = qr{(?>[^\x81-\xFE0-9A-Z_a-z]|[\x81-\xFE][\x00-\xFF])};
547             ${Ebig5hkscs::eH} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
548             ${Ebig5hkscs::eV} = qr{(?>[^\x81-\xFE\x0A\x0B\x0C\x0D]|[\x81-\xFE][\x00-\xFF])};
549             ${Ebig5hkscs::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
550             ${Ebig5hkscs::eN} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
551             ${Ebig5hkscs::not_alnum} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
552             ${Ebig5hkscs::not_alpha} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
553             ${Ebig5hkscs::not_ascii} = qr{(?>[^\x81-\xFE\x00-\x7F]|[\x81-\xFE][\x00-\xFF])};
554             ${Ebig5hkscs::not_blank} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
555             ${Ebig5hkscs::not_cntrl} = qr{(?>[^\x81-\xFE\x00-\x1F\x7F]|[\x81-\xFE][\x00-\xFF])};
556             ${Ebig5hkscs::not_digit} = qr{(?>[^\x81-\xFE\x30-\x39]|[\x81-\xFE][\x00-\xFF])};
557             ${Ebig5hkscs::not_graph} = qr{(?>[^\x81-\xFE\x21-\x7F]|[\x81-\xFE][\x00-\xFF])};
558             ${Ebig5hkscs::not_lower} = qr{(?>[^\x81-\xFE\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
559             ${Ebig5hkscs::not_lower_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
560             # ${Ebig5hkscs::not_lower_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
561             ${Ebig5hkscs::not_print} = qr{(?>[^\x81-\xFE\x20-\x7F]|[\x81-\xFE][\x00-\xFF])};
562             ${Ebig5hkscs::not_punct} = qr{(?>[^\x81-\xFE\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]|[\x81-\xFE][\x00-\xFF])};
563             ${Ebig5hkscs::not_space} = qr{(?>[^\x81-\xFE\s\x0B]|[\x81-\xFE][\x00-\xFF])};
564             ${Ebig5hkscs::not_upper} = qr{(?>[^\x81-\xFE\x41-\x5A]|[\x81-\xFE][\x00-\xFF])};
565             ${Ebig5hkscs::not_upper_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
566             # ${Ebig5hkscs::not_upper_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
567             ${Ebig5hkscs::not_word} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x5F\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
568             ${Ebig5hkscs::not_xdigit} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x46\x61-\x66]|[\x81-\xFE][\x00-\xFF])};
569             ${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))};
570             ${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]))};
571              
572             # avoid: Name "Ebig5hkscs::foo" used only once: possible typo at here.
573             ${Ebig5hkscs::dot} = ${Ebig5hkscs::dot};
574             ${Ebig5hkscs::dot_s} = ${Ebig5hkscs::dot_s};
575             ${Ebig5hkscs::eD} = ${Ebig5hkscs::eD};
576             ${Ebig5hkscs::eS} = ${Ebig5hkscs::eS};
577             ${Ebig5hkscs::eW} = ${Ebig5hkscs::eW};
578             ${Ebig5hkscs::eH} = ${Ebig5hkscs::eH};
579             ${Ebig5hkscs::eV} = ${Ebig5hkscs::eV};
580             ${Ebig5hkscs::eR} = ${Ebig5hkscs::eR};
581             ${Ebig5hkscs::eN} = ${Ebig5hkscs::eN};
582             ${Ebig5hkscs::not_alnum} = ${Ebig5hkscs::not_alnum};
583             ${Ebig5hkscs::not_alpha} = ${Ebig5hkscs::not_alpha};
584             ${Ebig5hkscs::not_ascii} = ${Ebig5hkscs::not_ascii};
585             ${Ebig5hkscs::not_blank} = ${Ebig5hkscs::not_blank};
586             ${Ebig5hkscs::not_cntrl} = ${Ebig5hkscs::not_cntrl};
587             ${Ebig5hkscs::not_digit} = ${Ebig5hkscs::not_digit};
588             ${Ebig5hkscs::not_graph} = ${Ebig5hkscs::not_graph};
589             ${Ebig5hkscs::not_lower} = ${Ebig5hkscs::not_lower};
590             ${Ebig5hkscs::not_lower_i} = ${Ebig5hkscs::not_lower_i};
591             ${Ebig5hkscs::not_print} = ${Ebig5hkscs::not_print};
592             ${Ebig5hkscs::not_punct} = ${Ebig5hkscs::not_punct};
593             ${Ebig5hkscs::not_space} = ${Ebig5hkscs::not_space};
594             ${Ebig5hkscs::not_upper} = ${Ebig5hkscs::not_upper};
595             ${Ebig5hkscs::not_upper_i} = ${Ebig5hkscs::not_upper_i};
596             ${Ebig5hkscs::not_word} = ${Ebig5hkscs::not_word};
597             ${Ebig5hkscs::not_xdigit} = ${Ebig5hkscs::not_xdigit};
598             ${Ebig5hkscs::eb} = ${Ebig5hkscs::eb};
599             ${Ebig5hkscs::eB} = ${Ebig5hkscs::eB};
600              
601             #
602             # Big5-HKSCS split
603             #
604             sub Ebig5hkscs::split(;$$$) {
605              
606             # P.794 29.2.161. split
607             # in Chapter 29: Functions
608             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
609              
610             # P.951 split
611             # in Chapter 27: Functions
612             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
613              
614 5     0 0 11725 my $pattern = $_[0];
615 0         0 my $string = $_[1];
616 0         0 my $limit = $_[2];
617              
618             # if $pattern is also omitted or is the literal space, " "
619 0 0       0 if (not defined $pattern) {
620 0         0 $pattern = ' ';
621             }
622              
623             # if $string is omitted, the function splits the $_ string
624 0 0       0 if (not defined $string) {
625 0 0       0 if (defined $_) {
626 0         0 $string = $_;
627             }
628             else {
629 0         0 $string = '';
630             }
631             }
632              
633 0         0 my @split = ();
634              
635             # when string is empty
636 0 0       0 if ($string eq '') {
    0          
637              
638             # resulting list value in list context
639 0 0       0 if (wantarray) {
640 0         0 return @split;
641             }
642              
643             # count of substrings in scalar context
644             else {
645 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
646 0         0 @_ = @split;
647 0         0 return scalar @_;
648             }
649             }
650              
651             # split's first argument is more consistently interpreted
652             #
653             # After some changes earlier in v5.17, split's behavior has been simplified:
654             # if the PATTERN argument evaluates to a string containing one space, it is
655             # treated the way that a literal string containing one space once was.
656             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
657              
658             # if $pattern is also omitted or is the literal space, " ", the function splits
659             # on whitespace, /\s+/, after skipping any leading whitespace
660             # (and so on)
661              
662             elsif ($pattern eq ' ') {
663 0 0       0 if (not defined $limit) {
664 0         0 return CORE::split(' ', $string);
665             }
666             else {
667 0         0 return CORE::split(' ', $string, $limit);
668             }
669             }
670              
671 0         0 local $q_char = $q_char;
672 0 0       0 if (CORE::length($string) > 32766) {
673 0 0       0 if ($string =~ /\A [\x00-\x7F]+ \z/oxms) {
    0          
674 0         0 $q_char = qr{.}s;
675             }
676             elsif (defined ${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17}) {
677 0         0 $q_char = ${Ebig5hkscs::q_char_SADAHIRO_Tomoyuki_2002_01_17};
678             }
679             }
680              
681             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
682 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
683              
684             # a pattern capable of matching either the null string or something longer than the
685             # null string will split the value of $string into separate characters wherever it
686             # matches the null string between characters
687             # (and so on)
688              
689 0 0       0 if ('' =~ / \A $pattern \z /xms) {
690 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
691 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
692              
693             # P.1024 Appendix W.10 Multibyte Processing
694             # of ISBN 1-56592-224-7 CJKV Information Processing
695             # (and so on)
696              
697             # the //m modifier is assumed when you split on the pattern /^/
698             # (and so on)
699              
700             # V
701 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
702              
703             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
704             # is included in the resulting list, interspersed with the fields that are ordinarily returned
705             # (and so on)
706              
707 0         0 local $@;
708 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
709 0         0 push @split, CORE::eval('$' . $digit);
710             }
711             }
712             }
713              
714             else {
715 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
716              
717             # V
718 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
719 0         0 local $@;
720 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
721 0         0 push @split, CORE::eval('$' . $digit);
722             }
723             }
724             }
725             }
726              
727             elsif ($limit > 0) {
728 0 0       0 if ('' =~ / \A $pattern \z /xms) {
729 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
730 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
731              
732             # V
733 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
734 0         0 local $@;
735 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
736 0         0 push @split, CORE::eval('$' . $digit);
737             }
738             }
739             }
740             }
741             else {
742 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
743 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
744              
745             # V
746 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
747 0         0 local $@;
748 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
749 0         0 push @split, CORE::eval('$' . $digit);
750             }
751             }
752             }
753             }
754             }
755              
756 0 0       0 if (CORE::length($string) > 0) {
757 0         0 push @split, $string;
758             }
759              
760             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
761 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
762 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
763 0         0 pop @split;
764             }
765             }
766              
767             # resulting list value in list context
768 0 0       0 if (wantarray) {
769 0         0 return @split;
770             }
771              
772             # count of substrings in scalar context
773             else {
774 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
775 0         0 @_ = @split;
776 0         0 return scalar @_;
777             }
778             }
779              
780             #
781             # get last subexpression offsets
782             #
783             sub _last_subexpression_offsets {
784 0     0   0 my $pattern = $_[0];
785              
786             # remove comment
787 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
788              
789 0         0 my $modifier = '';
790 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
791 0         0 $modifier = $1;
792 0         0 $modifier =~ s/-[A-Za-z]*//;
793             }
794              
795             # with /x modifier
796 0         0 my @char = ();
797 0 0       0 if ($modifier =~ /x/oxms) {
798 0         0 @char = $pattern =~ /\G((?>
799             [^\x81-\xFE\\\#\[\(]|[\x81-\xFE][\x00-\xFF] |
800             \\ $q_char |
801             \# (?>[^\n]*) $ |
802             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
803             \(\? |
804             $q_char
805             ))/oxmsg;
806             }
807              
808             # without /x modifier
809             else {
810 0         0 @char = $pattern =~ /\G((?>
811             [^\x81-\xFE\\\[\(]|[\x81-\xFE][\x00-\xFF] |
812             \\ $q_char |
813             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
814             \(\? |
815             $q_char
816             ))/oxmsg;
817             }
818              
819 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
820             }
821              
822             #
823             # Big5-HKSCS transliteration (tr///)
824             #
825             sub Ebig5hkscs::tr($$$$;$) {
826              
827 0     0 0 0 my $bind_operator = $_[1];
828 0         0 my $searchlist = $_[2];
829 0         0 my $replacementlist = $_[3];
830 0   0     0 my $modifier = $_[4] || '';
831              
832 0 0       0 if ($modifier =~ /r/oxms) {
833 0 0       0 if ($bind_operator =~ / !~ /oxms) {
834 0         0 croak "Using !~ with tr///r doesn't make sense";
835             }
836             }
837              
838 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
839 0         0 my @searchlist = _charlist_tr($searchlist);
840 0         0 my @replacementlist = _charlist_tr($replacementlist);
841              
842 0         0 my %tr = ();
843 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
844 0 0       0 if (not exists $tr{$searchlist[$i]}) {
845 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
846 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
847             }
848             elsif ($modifier =~ /d/oxms) {
849 0         0 $tr{$searchlist[$i]} = '';
850             }
851             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
852 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
853             }
854             else {
855 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
856             }
857             }
858             }
859              
860 0         0 my $tr = 0;
861 0         0 my $replaced = '';
862 0 0       0 if ($modifier =~ /c/oxms) {
863 0         0 while (defined(my $char = shift @char)) {
864 0 0       0 if (not exists $tr{$char}) {
865 0 0       0 if (defined $replacementlist[0]) {
866 0         0 $replaced .= $replacementlist[0];
867             }
868 0         0 $tr++;
869 0 0       0 if ($modifier =~ /s/oxms) {
870 0   0     0 while (@char and (not exists $tr{$char[0]})) {
871 0         0 shift @char;
872 0         0 $tr++;
873             }
874             }
875             }
876             else {
877 0         0 $replaced .= $char;
878             }
879             }
880             }
881             else {
882 0         0 while (defined(my $char = shift @char)) {
883 0 0       0 if (exists $tr{$char}) {
884 0         0 $replaced .= $tr{$char};
885 0         0 $tr++;
886 0 0       0 if ($modifier =~ /s/oxms) {
887 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
888 0         0 shift @char;
889 0         0 $tr++;
890             }
891             }
892             }
893             else {
894 0         0 $replaced .= $char;
895             }
896             }
897             }
898              
899 0 0       0 if ($modifier =~ /r/oxms) {
900 0         0 return $replaced;
901             }
902             else {
903 0         0 $_[0] = $replaced;
904 0 0       0 if ($bind_operator =~ / !~ /oxms) {
905 0         0 return not $tr;
906             }
907             else {
908 0         0 return $tr;
909             }
910             }
911             }
912              
913             #
914             # Big5-HKSCS chop
915             #
916             sub Ebig5hkscs::chop(@) {
917              
918 0     0 0 0 my $chop;
919 0 0       0 if (@_ == 0) {
920 0         0 my @char = /\G (?>$q_char) /oxmsg;
921 0         0 $chop = pop @char;
922 0         0 $_ = join '', @char;
923             }
924             else {
925 0         0 for (@_) {
926 0         0 my @char = /\G (?>$q_char) /oxmsg;
927 0         0 $chop = pop @char;
928 0         0 $_ = join '', @char;
929             }
930             }
931 0         0 return $chop;
932             }
933              
934             #
935             # Big5-HKSCS index by octet
936             #
937             sub Ebig5hkscs::index($$;$) {
938              
939 0     2304 1 0 my($str,$substr,$position) = @_;
940 2304   50     4773 $position ||= 0;
941 2304         9089 my $pos = 0;
942              
943 2304         3104 while ($pos < CORE::length($str)) {
944 2304 50       5402 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
945 64284 0       96771 if ($pos >= $position) {
946 0         0 return $pos;
947             }
948             }
949 0 50       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
950 64284         142267 $pos += CORE::length($1);
951             }
952             else {
953 64284         115139 $pos += 1;
954             }
955             }
956 0         0 return -1;
957             }
958              
959             #
960             # Big5-HKSCS reverse index
961             #
962             sub Ebig5hkscs::rindex($$;$) {
963              
964 2304     0 0 13484 my($str,$substr,$position) = @_;
965 0   0     0 $position ||= CORE::length($str) - 1;
966 0         0 my $pos = 0;
967 0         0 my $rindex = -1;
968              
969 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
970 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
971 0         0 $rindex = $pos;
972             }
973 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
974 0         0 $pos += CORE::length($1);
975             }
976             else {
977 0         0 $pos += 1;
978             }
979             }
980 0         0 return $rindex;
981             }
982              
983             #
984             # Big5-HKSCS lower case first with parameter
985             #
986             sub Ebig5hkscs::lcfirst(@) {
987 0 0   0 0 0 if (@_) {
988 0         0 my $s = shift @_;
989 0 0 0     0 if (@_ and wantarray) {
990 0         0 return Ebig5hkscs::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
991             }
992             else {
993 0         0 return Ebig5hkscs::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
994             }
995             }
996             else {
997 0         0 return Ebig5hkscs::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
998             }
999             }
1000              
1001             #
1002             # Big5-HKSCS lower case first without parameter
1003             #
1004             sub Ebig5hkscs::lcfirst_() {
1005 0     0 0 0 return Ebig5hkscs::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1006             }
1007              
1008             #
1009             # Big5-HKSCS lower case with parameter
1010             #
1011             sub Ebig5hkscs::lc(@) {
1012 0 0   0 0 0 if (@_) {
1013 0         0 my $s = shift @_;
1014 0 0 0     0 if (@_ and wantarray) {
1015 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1016             }
1017             else {
1018 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1019             }
1020             }
1021             else {
1022 0         0 return Ebig5hkscs::lc_();
1023             }
1024             }
1025              
1026             #
1027             # Big5-HKSCS lower case without parameter
1028             #
1029             sub Ebig5hkscs::lc_() {
1030 0     0 0 0 my $s = $_;
1031 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1032             }
1033              
1034             #
1035             # Big5-HKSCS upper case first with parameter
1036             #
1037             sub Ebig5hkscs::ucfirst(@) {
1038 0 0   0 0 0 if (@_) {
1039 0         0 my $s = shift @_;
1040 0 0 0     0 if (@_ and wantarray) {
1041 0         0 return Ebig5hkscs::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1042             }
1043             else {
1044 0         0 return Ebig5hkscs::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1045             }
1046             }
1047             else {
1048 0         0 return Ebig5hkscs::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1049             }
1050             }
1051              
1052             #
1053             # Big5-HKSCS upper case first without parameter
1054             #
1055             sub Ebig5hkscs::ucfirst_() {
1056 0     0 0 0 return Ebig5hkscs::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1057             }
1058              
1059             #
1060             # Big5-HKSCS upper case with parameter
1061             #
1062             sub Ebig5hkscs::uc(@) {
1063 0 50   2968 0 0 if (@_) {
1064 2968         4688 my $s = shift @_;
1065 2968 50 33     3981 if (@_ and wantarray) {
1066 2968 0       5616 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1067             }
1068             else {
1069 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  2968         9360  
1070             }
1071             }
1072             else {
1073 2968         11053 return Ebig5hkscs::uc_();
1074             }
1075             }
1076              
1077             #
1078             # Big5-HKSCS upper case without parameter
1079             #
1080             sub Ebig5hkscs::uc_() {
1081 0     0 0 0 my $s = $_;
1082 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1083             }
1084              
1085             #
1086             # Big5-HKSCS fold case with parameter
1087             #
1088             sub Ebig5hkscs::fc(@) {
1089 0 50   3271 0 0 if (@_) {
1090 3271         4928 my $s = shift @_;
1091 3271 50 33     4260 if (@_ and wantarray) {
1092 3271 0       6131 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1093             }
1094             else {
1095 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3271         8846  
1096             }
1097             }
1098             else {
1099 3271         14289 return Ebig5hkscs::fc_();
1100             }
1101             }
1102              
1103             #
1104             # Big5-HKSCS fold case without parameter
1105             #
1106             sub Ebig5hkscs::fc_() {
1107 0     0 0 0 my $s = $_;
1108 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1109             }
1110              
1111             #
1112             # Big5-HKSCS regexp capture
1113             #
1114             {
1115             # 10.3. Creating Persistent Private Variables
1116             # in Chapter 10. Subroutines
1117             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
1118              
1119             my $last_s_matched = 0;
1120              
1121             sub Ebig5hkscs::capture {
1122 0 0 0 0 1 0 if ($last_s_matched and ($_[0] =~ /\A (?>[1-9][0-9]*) \z/oxms)) {
1123 0         0 return $_[0] + 1;
1124             }
1125 0         0 return $_[0];
1126             }
1127              
1128             # Big5-HKSCS mark last regexp matched
1129             sub Ebig5hkscs::matched() {
1130 0     0 0 0 $last_s_matched = 0;
1131             }
1132              
1133             # Big5-HKSCS mark last s/// matched
1134             sub Ebig5hkscs::s_matched() {
1135 0     0 0 0 $last_s_matched = 1;
1136             }
1137              
1138             # P.854 31.17. use re
1139             # in Chapter 31. Pragmatic Modules
1140             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1141              
1142             # P.1026 re
1143             # in Chapter 29. Pragmatic Modules
1144             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1145              
1146             $Ebig5hkscs::matched = qr/(?{Ebig5hkscs::matched})/;
1147             }
1148              
1149             #
1150             # Big5-HKSCS regexp ignore case modifier
1151             #
1152             sub Ebig5hkscs::ignorecase {
1153              
1154 0     0 0 0 my @string = @_;
1155 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1156              
1157             # ignore case of $scalar or @array
1158 0         0 for my $string (@string) {
1159              
1160             # split regexp
1161 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1162              
1163             # unescape character
1164 0         0 for (my $i=0; $i <= $#char; $i++) {
1165 0 0       0 next if not defined $char[$i];
1166              
1167             # open character class [...]
1168 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1169 0         0 my $left = $i;
1170              
1171             # [] make die "unmatched [] in regexp ...\n"
1172              
1173 0 0       0 if ($char[$i+1] eq ']') {
1174 0         0 $i++;
1175             }
1176              
1177 0         0 while (1) {
1178 0 0       0 if (++$i > $#char) {
1179 0         0 croak "Unmatched [] in regexp";
1180             }
1181 0 0       0 if ($char[$i] eq ']') {
1182 0         0 my $right = $i;
1183 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1184              
1185             # escape character
1186 0         0 for my $char (@charlist) {
1187 0 0       0 if (0) {
    0          
1188             }
1189              
1190             # do not use quotemeta here
1191 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1192 0         0 $char = $1 . '\\' . $2;
1193             }
1194             elsif ($char =~ /\A [.|)] \z/oxms) {
1195 0         0 $char = '\\' . $char;
1196             }
1197             }
1198              
1199             # [...]
1200 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1201              
1202 0         0 $i = $left;
1203 0         0 last;
1204             }
1205             }
1206             }
1207              
1208             # open character class [^...]
1209             elsif ($char[$i] eq '[^') {
1210 0         0 my $left = $i;
1211              
1212             # [^] make die "unmatched [] in regexp ...\n"
1213              
1214 0 0       0 if ($char[$i+1] eq ']') {
1215 0         0 $i++;
1216             }
1217              
1218 0         0 while (1) {
1219 0 0       0 if (++$i > $#char) {
1220 0         0 croak "Unmatched [] in regexp";
1221             }
1222 0 0       0 if ($char[$i] eq ']') {
1223 0         0 my $right = $i;
1224 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1225              
1226             # escape character
1227 0         0 for my $char (@charlist) {
1228 0 0       0 if (0) {
    0          
1229             }
1230              
1231             # do not use quotemeta here
1232 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1233 0         0 $char = $1 . '\\' . $2;
1234             }
1235             elsif ($char =~ /\A [.|)] \z/oxms) {
1236 0         0 $char = '\\' . $char;
1237             }
1238             }
1239              
1240             # [^...]
1241 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1242              
1243 0         0 $i = $left;
1244 0         0 last;
1245             }
1246             }
1247             }
1248              
1249             # rewrite classic character class or escape character
1250             elsif (my $char = classic_character_class($char[$i])) {
1251 0         0 $char[$i] = $char;
1252             }
1253              
1254             # with /i modifier
1255             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1256 0         0 my $uc = Ebig5hkscs::uc($char[$i]);
1257 0         0 my $fc = Ebig5hkscs::fc($char[$i]);
1258 0 0       0 if ($uc ne $fc) {
1259 0 0       0 if (CORE::length($fc) == 1) {
1260 0         0 $char[$i] = '[' . $uc . $fc . ']';
1261             }
1262             else {
1263 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1264             }
1265             }
1266             }
1267             }
1268              
1269             # characterize
1270 0         0 for (my $i=0; $i <= $#char; $i++) {
1271 0 0       0 next if not defined $char[$i];
1272              
1273 0 0 0     0 if (0) {
    0          
1274             }
1275              
1276             # escape last octet of multiple-octet
1277 0         0 elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1278 0         0 $char[$i] = $1 . '\\' . $2;
1279             }
1280              
1281             # quote character before ? + * {
1282             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1283 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1284 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1285             }
1286             }
1287             }
1288              
1289 0         0 $string = join '', @char;
1290             }
1291              
1292             # make regexp string
1293 0         0 return @string;
1294             }
1295              
1296             #
1297             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1298             #
1299             sub Ebig5hkscs::classic_character_class {
1300 0     5319 0 0 my($char) = @_;
1301              
1302             return {
1303             '\D' => '${Ebig5hkscs::eD}',
1304             '\S' => '${Ebig5hkscs::eS}',
1305             '\W' => '${Ebig5hkscs::eW}',
1306             '\d' => '[0-9]',
1307              
1308             # Before Perl 5.6, \s only matched the five whitespace characters
1309             # tab, newline, form-feed, carriage return, and the space character
1310             # itself, which, taken together, is the character class [\t\n\f\r ].
1311              
1312             # Vertical tabs are now whitespace
1313             # \s in a regex now matches a vertical tab in all circumstances.
1314             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1315             # \t \n \v \f \r space
1316             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1317             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1318             '\s' => '\s',
1319              
1320             '\w' => '[0-9A-Z_a-z]',
1321             '\C' => '[\x00-\xFF]',
1322             '\X' => 'X',
1323              
1324             # \h \v \H \V
1325              
1326             # P.114 Character Class Shortcuts
1327             # in Chapter 7: In the World of Regular Expressions
1328             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1329              
1330             # P.357 13.2.3 Whitespace
1331             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1332             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1333             #
1334             # 0x00009 CHARACTER TABULATION h s
1335             # 0x0000a LINE FEED (LF) vs
1336             # 0x0000b LINE TABULATION v
1337             # 0x0000c FORM FEED (FF) vs
1338             # 0x0000d CARRIAGE RETURN (CR) vs
1339             # 0x00020 SPACE h s
1340              
1341             # P.196 Table 5-9. Alphanumeric regex metasymbols
1342             # in Chapter 5. Pattern Matching
1343             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1344              
1345             # (and so on)
1346              
1347             '\H' => '${Ebig5hkscs::eH}',
1348             '\V' => '${Ebig5hkscs::eV}',
1349             '\h' => '[\x09\x20]',
1350             '\v' => '[\x0A\x0B\x0C\x0D]',
1351             '\R' => '${Ebig5hkscs::eR}',
1352              
1353             # \N
1354             #
1355             # http://perldoc.perl.org/perlre.html
1356             # Character Classes and other Special Escapes
1357             # Any character but \n (experimental). Not affected by /s modifier
1358              
1359             '\N' => '${Ebig5hkscs::eN}',
1360              
1361             # \b \B
1362              
1363             # P.180 Boundaries: The \b and \B Assertions
1364             # in Chapter 5: Pattern Matching
1365             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1366              
1367             # P.219 Boundaries: The \b and \B Assertions
1368             # in Chapter 5: Pattern Matching
1369             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1370              
1371             # \b really means (?:(?<=\w)(?!\w)|(?
1372             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1373             '\b' => '${Ebig5hkscs::eb}',
1374              
1375             # \B really means (?:(?<=\w)(?=\w)|(?
1376             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1377             '\B' => '${Ebig5hkscs::eB}',
1378              
1379 5319   100     7878 }->{$char} || '';
1380             }
1381              
1382             #
1383             # prepare Big5-HKSCS characters per length
1384             #
1385              
1386             # 1 octet characters
1387             my @chars1 = ();
1388             sub chars1 {
1389 5319 0   0 0 181341 if (@chars1) {
1390 0         0 return @chars1;
1391             }
1392 0 0       0 if (exists $range_tr{1}) {
1393 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1394 0         0 while (my @range = splice(@ranges,0,1)) {
1395 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1396 0         0 push @chars1, pack 'C', $oct0;
1397             }
1398             }
1399             }
1400 0         0 return @chars1;
1401             }
1402              
1403             # 2 octets characters
1404             my @chars2 = ();
1405             sub chars2 {
1406 0 0   0 0 0 if (@chars2) {
1407 0         0 return @chars2;
1408             }
1409 0 0       0 if (exists $range_tr{2}) {
1410 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1411 0         0 while (my @range = splice(@ranges,0,2)) {
1412 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1413 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1414 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1415             }
1416             }
1417             }
1418             }
1419 0         0 return @chars2;
1420             }
1421              
1422             # 3 octets characters
1423             my @chars3 = ();
1424             sub chars3 {
1425 0 0   0 0 0 if (@chars3) {
1426 0         0 return @chars3;
1427             }
1428 0 0       0 if (exists $range_tr{3}) {
1429 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1430 0         0 while (my @range = splice(@ranges,0,3)) {
1431 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1432 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1433 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1434 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1435             }
1436             }
1437             }
1438             }
1439             }
1440 0         0 return @chars3;
1441             }
1442              
1443             # 4 octets characters
1444             my @chars4 = ();
1445             sub chars4 {
1446 0 0   0 0 0 if (@chars4) {
1447 0         0 return @chars4;
1448             }
1449 0 0       0 if (exists $range_tr{4}) {
1450 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1451 0         0 while (my @range = splice(@ranges,0,4)) {
1452 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1453 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1454 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1455 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1456 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1457             }
1458             }
1459             }
1460             }
1461             }
1462             }
1463 0         0 return @chars4;
1464             }
1465              
1466             #
1467             # Big5-HKSCS open character list for tr
1468             #
1469             sub _charlist_tr {
1470              
1471 0     0   0 local $_ = shift @_;
1472              
1473             # unescape character
1474 0         0 my @char = ();
1475 0         0 while (not /\G \z/oxmsgc) {
1476 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1477 0         0 push @char, '\-';
1478             }
1479             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1480 0         0 push @char, CORE::chr(oct $1);
1481             }
1482             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1483 0         0 push @char, CORE::chr(hex $1);
1484             }
1485             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1486 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1487             }
1488             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1489             push @char, {
1490             '\0' => "\0",
1491             '\n' => "\n",
1492             '\r' => "\r",
1493             '\t' => "\t",
1494             '\f' => "\f",
1495             '\b' => "\x08", # \b means backspace in character class
1496             '\a' => "\a",
1497             '\e' => "\e",
1498 0         0 }->{$1};
1499             }
1500             elsif (/\G \\ ($q_char) /oxmsgc) {
1501 0         0 push @char, $1;
1502             }
1503             elsif (/\G ($q_char) /oxmsgc) {
1504 0         0 push @char, $1;
1505             }
1506             }
1507              
1508             # join separated multiple-octet
1509 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1510              
1511             # unescape '-'
1512 0         0 my @i = ();
1513 0         0 for my $i (0 .. $#char) {
1514 0 0       0 if ($char[$i] eq '\-') {
    0          
1515 0         0 $char[$i] = '-';
1516             }
1517             elsif ($char[$i] eq '-') {
1518 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1519 0         0 push @i, $i;
1520             }
1521             }
1522             }
1523              
1524             # open character list (reverse for splice)
1525 0         0 for my $i (CORE::reverse @i) {
1526 0         0 my @range = ();
1527              
1528             # range error
1529 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1530 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1531             }
1532              
1533             # range of multiple-octet code
1534 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1535 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1536 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1537             }
1538             elsif (CORE::length($char[$i+1]) == 2) {
1539 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1540 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1541             }
1542             elsif (CORE::length($char[$i+1]) == 3) {
1543 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1544 0         0 push @range, chars2();
1545 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1546             }
1547             elsif (CORE::length($char[$i+1]) == 4) {
1548 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1549 0         0 push @range, chars2();
1550 0         0 push @range, chars3();
1551 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1552             }
1553             else {
1554 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1555             }
1556             }
1557             elsif (CORE::length($char[$i-1]) == 2) {
1558 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1559 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1560             }
1561             elsif (CORE::length($char[$i+1]) == 3) {
1562 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1563 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1564             }
1565             elsif (CORE::length($char[$i+1]) == 4) {
1566 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1567 0         0 push @range, chars3();
1568 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1569             }
1570             else {
1571 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1572             }
1573             }
1574             elsif (CORE::length($char[$i-1]) == 3) {
1575 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1576 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1577             }
1578             elsif (CORE::length($char[$i+1]) == 4) {
1579 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1580 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1581             }
1582             else {
1583 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1584             }
1585             }
1586             elsif (CORE::length($char[$i-1]) == 4) {
1587 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1588 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1589             }
1590             else {
1591 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1592             }
1593             }
1594             else {
1595 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1596             }
1597              
1598 0         0 splice @char, $i-1, 3, @range;
1599             }
1600              
1601 0         0 return @char;
1602             }
1603              
1604             #
1605             # Big5-HKSCS open character class
1606             #
1607             sub _cc {
1608 0 50   604   0 if (scalar(@_) == 0) {
    100          
    50          
1609 604         1362 die __FILE__, ": subroutine cc got no parameter.\n";
1610             }
1611             elsif (scalar(@_) == 1) {
1612 0         0 return sprintf('\x%02X',$_[0]);
1613             }
1614             elsif (scalar(@_) == 2) {
1615 302 50       1085 if ($_[0] > $_[1]) {
    50          
    50          
1616 302         802 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1617             }
1618             elsif ($_[0] == $_[1]) {
1619 0         0 return sprintf('\x%02X',$_[0]);
1620             }
1621             elsif (($_[0]+1) == $_[1]) {
1622 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1623             }
1624             else {
1625 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1626             }
1627             }
1628             else {
1629 302         1637 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1630             }
1631             }
1632              
1633             #
1634             # Big5-HKSCS octet range
1635             #
1636             sub _octets {
1637 0     668   0 my $length = shift @_;
1638              
1639 668 100       1144 if ($length == 1) {
    50          
    0          
    0          
1640 668         1460 my($a1) = unpack 'C', $_[0];
1641 406         1140 my($z1) = unpack 'C', $_[1];
1642              
1643 406 50       757 if ($a1 > $z1) {
1644 406         818 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1645             }
1646              
1647 0 100       0 if ($a1 == $z1) {
    50          
1648 406         994 return sprintf('\x%02X',$a1);
1649             }
1650             elsif (($a1+1) == $z1) {
1651 20         94 return sprintf('\x%02X\x%02X',$a1,$z1);
1652             }
1653             else {
1654 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1655             }
1656             }
1657             elsif ($length == 2) {
1658 386         2493 my($a1,$a2) = unpack 'CC', $_[0];
1659 262         660 my($z1,$z2) = unpack 'CC', $_[1];
1660 262         485 my($A1,$A2) = unpack 'CC', $_[2];
1661 262         482 my($Z1,$Z2) = unpack 'CC', $_[3];
1662              
1663 262 100       467 if ($a1 == $z1) {
    50          
1664             return (
1665             # 11111111 222222222222
1666             # A A Z
1667 262         504 _cc($a1) . _cc($a2,$z2), # a2-z2
1668             );
1669             }
1670             elsif (($a1+1) == $z1) {
1671             return (
1672             # 11111111111 222222222222
1673             # A Z A Z
1674 222         411 _cc($a1) . _cc($a2,$Z2), # a2-
1675             _cc( $z1) . _cc($A2,$z2), # -z2
1676             );
1677             }
1678             else {
1679             return (
1680             # 1111111111111111 222222222222
1681             # A Z A Z
1682 40         84 _cc($a1) . _cc($a2,$Z2), # a2-
1683             _cc($a1+1,$z1-1) . _cc($A2,$Z2), # -
1684             _cc( $z1) . _cc($A2,$z2), # -z2
1685             );
1686             }
1687             }
1688             elsif ($length == 3) {
1689 0         0 my($a1,$a2,$a3) = unpack 'CCC', $_[0];
1690 0         0 my($z1,$z2,$z3) = unpack 'CCC', $_[1];
1691 0         0 my($A1,$A2,$A3) = unpack 'CCC', $_[2];
1692 0         0 my($Z1,$Z2,$Z3) = unpack 'CCC', $_[3];
1693              
1694 0 0       0 if ($a1 == $z1) {
    0          
1695 0 0       0 if ($a2 == $z2) {
    0          
1696             return (
1697             # 11111111 22222222 333333333333
1698             # A A A Z
1699 0         0 _cc($a1) . _cc($a2) . _cc($a3,$z3), # a3-z3
1700             );
1701             }
1702             elsif (($a2+1) == $z2) {
1703             return (
1704             # 11111111 22222222222 333333333333
1705             # A A Z A Z
1706 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1707             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1708             );
1709             }
1710             else {
1711             return (
1712             # 11111111 2222222222222222 333333333333
1713             # A A Z A Z
1714 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1715             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3), # -
1716             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1717             );
1718             }
1719             }
1720             elsif (($a1+1) == $z1) {
1721             return (
1722             # 11111111111 22222222222222 333333333333
1723             # A Z A Z A Z
1724 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1725             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1726             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1727             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1728             );
1729             }
1730             else {
1731             return (
1732             # 1111111111111111 22222222222222 333333333333
1733             # A Z A Z A Z
1734 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1735             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1736             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3), # -
1737             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1738             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1739             );
1740             }
1741             }
1742             elsif ($length == 4) {
1743 0         0 my($a1,$a2,$a3,$a4) = unpack 'CCCC', $_[0];
1744 0         0 my($z1,$z2,$z3,$z4) = unpack 'CCCC', $_[1];
1745 0         0 my($A1,$A2,$A3,$A4) = unpack 'CCCC', $_[0];
1746 0         0 my($Z1,$Z2,$Z3,$Z4) = unpack 'CCCC', $_[1];
1747              
1748 0 0       0 if ($a1 == $z1) {
    0          
1749 0 0       0 if ($a2 == $z2) {
    0          
1750 0 0       0 if ($a3 == $z3) {
    0          
1751             return (
1752             # 11111111 22222222 33333333 444444444444
1753             # A A A A Z
1754 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$z4), # a4-z4
1755             );
1756             }
1757             elsif (($a3+1) == $z3) {
1758             return (
1759             # 11111111 22222222 33333333333 444444444444
1760             # A A A Z A Z
1761 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1762             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1763             );
1764             }
1765             else {
1766             return (
1767             # 11111111 22222222 3333333333333333 444444444444
1768             # A A A Z A Z
1769 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1770             _cc($a1) . _cc($a2) . _cc($a3+1,$z3-1) . _cc($A4,$Z4), # -
1771             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1772             );
1773             }
1774             }
1775             elsif (($a2+1) == $z2) {
1776             return (
1777             # 11111111 22222222222 33333333333333 444444444444
1778             # A A Z A Z A Z
1779 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1780             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1781             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1782             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1783             );
1784             }
1785             else {
1786             return (
1787             # 11111111 2222222222222222 33333333333333 444444444444
1788             # A A Z A Z A Z
1789 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1790             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1791             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1792             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1793             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1794             );
1795             }
1796             }
1797             elsif (($a1+1) == $z1) {
1798             return (
1799             # 11111111111 22222222222222 33333333333333 444444444444
1800             # A Z A Z A Z A Z
1801 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1802             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1803             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1804             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1805             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1806             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1807             );
1808             }
1809             else {
1810             return (
1811             # 1111111111111111 22222222222222 33333333333333 444444444444
1812             # A Z A Z A Z A Z
1813 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1814             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1815             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1816             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1817             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1818             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1819             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1820             );
1821             }
1822             }
1823             else {
1824 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1825             }
1826             }
1827              
1828             #
1829             # Big5-HKSCS range regexp
1830             #
1831             sub _range_regexp {
1832 0     517   0 my($length,$first,$last) = @_;
1833              
1834 517         1142 my @range_regexp = ();
1835 517 50       749 if (not exists $range_tr{$length}) {
1836 517         1254 return @range_regexp;
1837             }
1838              
1839 0         0 my @ranges = @{ $range_tr{$length} };
  517         780  
1840 517         1204 while (my @range = splice(@ranges,0,$length)) {
1841 517         1740 my $min = '';
1842 1034         1640 my $max = '';
1843 1034         1386 for (my $i=0; $i < $length; $i++) {
1844 1034         2156 $min .= pack 'C', $range[$i][0];
1845 1296         2965 $max .= pack 'C', $range[$i][-1];
1846             }
1847              
1848             # min___max
1849             # FIRST_____________LAST
1850             # (nothing)
1851              
1852 1296 50 66     2762 if ($max lt $first) {
    100 100        
    50 33        
    100 100        
    100 66        
    100 66        
    50 66        
1853             }
1854              
1855             # **********
1856             # min_________max
1857             # FIRST_____________LAST
1858             # **********
1859              
1860             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1861 1034         9246 push @range_regexp, _octets($length,$first,$max,$min,$max);
1862             }
1863              
1864             # **********************
1865             # min________________max
1866             # FIRST_____________LAST
1867             # **********************
1868              
1869             elsif (($min eq $first) and ($max eq $last)) {
1870 20         53 push @range_regexp, _octets($length,$first,$last,$min,$max);
1871             }
1872              
1873             # *********
1874             # min___max
1875             # FIRST_____________LAST
1876             # *********
1877              
1878             elsif (($first le $min) and ($max le $last)) {
1879 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1880             }
1881              
1882             # **********************
1883             # min__________________________max
1884             # FIRST_____________LAST
1885             # **********************
1886              
1887             elsif (($min le $first) and ($last le $max)) {
1888 20         54 push @range_regexp, _octets($length,$first,$last,$min,$max);
1889             }
1890              
1891             # *********
1892             # min________max
1893             # FIRST_____________LAST
1894             # *********
1895              
1896             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1897 588         1408 push @range_regexp, _octets($length,$min,$last,$min,$max);
1898             }
1899              
1900             # min___max
1901             # FIRST_____________LAST
1902             # (nothing)
1903              
1904             elsif ($last lt $min) {
1905             }
1906              
1907             else {
1908 40         96 die __FILE__, ": subroutine _range_regexp panic.\n";
1909             }
1910             }
1911              
1912 0         0 return @range_regexp;
1913             }
1914              
1915             #
1916             # Big5-HKSCS open character list for qr and not qr
1917             #
1918             sub _charlist {
1919              
1920 517     758   1283 my $modifier = pop @_;
1921 758         1256 my @char = @_;
1922              
1923 758 100       1798 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1924              
1925             # unescape character
1926 758         1997 for (my $i=0; $i <= $#char; $i++) {
1927              
1928             # escape - to ...
1929 758 100 100     2260 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1930 2648 100 100     18702 if ((0 < $i) and ($i < $#char)) {
1931 522         1844 $char[$i] = '...';
1932             }
1933             }
1934              
1935             # octal escape sequence
1936             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1937 497         1115 $char[$i] = octchr($1);
1938             }
1939              
1940             # hexadecimal escape sequence
1941             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1942 0         0 $char[$i] = hexchr($1);
1943             }
1944              
1945             # \b{...} --> b\{...}
1946             # \B{...} --> B\{...}
1947             # \N{CHARNAME} --> N\{CHARNAME}
1948             # \p{PROPERTY} --> p\{PROPERTY}
1949             # \P{PROPERTY} --> P\{PROPERTY}
1950             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
1951 0         0 $char[$i] = $1 . '\\' . $2;
1952             }
1953              
1954             # \p, \P, \X --> p, P, X
1955             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1956 0         0 $char[$i] = $1;
1957             }
1958              
1959             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1960 0         0 $char[$i] = CORE::chr oct $1;
1961             }
1962             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1963 0         0 $char[$i] = CORE::chr hex $1;
1964             }
1965             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1966 206         897 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1967             }
1968             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1969             $char[$i] = {
1970             '\0' => "\0",
1971             '\n' => "\n",
1972             '\r' => "\r",
1973             '\t' => "\t",
1974             '\f' => "\f",
1975             '\b' => "\x08", # \b means backspace in character class
1976             '\a' => "\a",
1977             '\e' => "\e",
1978             '\d' => '[0-9]',
1979              
1980             # Vertical tabs are now whitespace
1981             # \s in a regex now matches a vertical tab in all circumstances.
1982             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1983             # \t \n \v \f \r space
1984             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1985             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1986             '\s' => '\s',
1987              
1988             '\w' => '[0-9A-Z_a-z]',
1989             '\D' => '${Ebig5hkscs::eD}',
1990             '\S' => '${Ebig5hkscs::eS}',
1991             '\W' => '${Ebig5hkscs::eW}',
1992              
1993             '\H' => '${Ebig5hkscs::eH}',
1994             '\V' => '${Ebig5hkscs::eV}',
1995             '\h' => '[\x09\x20]',
1996             '\v' => '[\x0A\x0B\x0C\x0D]',
1997             '\R' => '${Ebig5hkscs::eR}',
1998              
1999 0         0 }->{$1};
2000             }
2001              
2002             # POSIX-style character classes
2003             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
2004             $char[$i] = {
2005              
2006             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
2007             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
2008             '[:^lower:]' => '${Ebig5hkscs::not_lower_i}',
2009             '[:^upper:]' => '${Ebig5hkscs::not_upper_i}',
2010              
2011 33         607 }->{$1};
2012             }
2013             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
2014             $char[$i] = {
2015              
2016             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
2017             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
2018             '[:ascii:]' => '[\x00-\x7F]',
2019             '[:blank:]' => '[\x09\x20]',
2020             '[:cntrl:]' => '[\x00-\x1F\x7F]',
2021             '[:digit:]' => '[\x30-\x39]',
2022             '[:graph:]' => '[\x21-\x7F]',
2023             '[:lower:]' => '[\x61-\x7A]',
2024             '[:print:]' => '[\x20-\x7F]',
2025             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
2026              
2027             # P.174 POSIX-Style Character Classes
2028             # in Chapter 5: Pattern Matching
2029             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2030              
2031             # P.311 11.2.4 Character Classes and other Special Escapes
2032             # in Chapter 11: perlre: Perl regular expressions
2033             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2034              
2035             # P.210 POSIX-Style Character Classes
2036             # in Chapter 5: Pattern Matching
2037             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2038              
2039             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
2040              
2041             '[:upper:]' => '[\x41-\x5A]',
2042             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
2043             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
2044             '[:^alnum:]' => '${Ebig5hkscs::not_alnum}',
2045             '[:^alpha:]' => '${Ebig5hkscs::not_alpha}',
2046             '[:^ascii:]' => '${Ebig5hkscs::not_ascii}',
2047             '[:^blank:]' => '${Ebig5hkscs::not_blank}',
2048             '[:^cntrl:]' => '${Ebig5hkscs::not_cntrl}',
2049             '[:^digit:]' => '${Ebig5hkscs::not_digit}',
2050             '[:^graph:]' => '${Ebig5hkscs::not_graph}',
2051             '[:^lower:]' => '${Ebig5hkscs::not_lower}',
2052             '[:^print:]' => '${Ebig5hkscs::not_print}',
2053             '[:^punct:]' => '${Ebig5hkscs::not_punct}',
2054             '[:^space:]' => '${Ebig5hkscs::not_space}',
2055             '[:^upper:]' => '${Ebig5hkscs::not_upper}',
2056             '[:^word:]' => '${Ebig5hkscs::not_word}',
2057             '[:^xdigit:]' => '${Ebig5hkscs::not_xdigit}',
2058              
2059 8         64 }->{$1};
2060             }
2061             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
2062 70         1361 $char[$i] = $1;
2063             }
2064             }
2065              
2066             # open character list
2067 7         41 my @singleoctet = ();
2068 758         1325 my @multipleoctet = ();
2069 758         1192 for (my $i=0; $i <= $#char; ) {
2070              
2071             # escaped -
2072 758 100 100     1674 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
2073 2151         9166 $i += 1;
2074 497         761 next;
2075             }
2076              
2077             # make range regexp
2078             elsif ($char[$i] eq '...') {
2079              
2080             # range error
2081 497 50       1000 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    100          
2082 497         1760 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2083             }
2084             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
2085 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
2086 477         1128 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2087             }
2088             }
2089              
2090             # make range regexp per length
2091 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
2092 497         1397 my @regexp = ();
2093              
2094             # is first and last
2095 517 100 100     787 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    100 33        
    50          
    50          
2096 517         2063 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
2097             }
2098              
2099             # is first
2100             elsif ($length == CORE::length($char[$i-1])) {
2101 477         1340 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
2102             }
2103              
2104             # is inside in first and last
2105             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
2106 20         88 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
2107             }
2108              
2109             # is last
2110             elsif ($length == CORE::length($char[$i+1])) {
2111 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
2112             }
2113              
2114             else {
2115 20         108 die __FILE__, ": subroutine make_regexp panic.\n";
2116             }
2117              
2118 0 100       0 if ($length == 1) {
2119 517         1205 push @singleoctet, @regexp;
2120             }
2121             else {
2122 386         945 push @multipleoctet, @regexp;
2123             }
2124             }
2125              
2126 131         337 $i += 2;
2127             }
2128              
2129             # with /i modifier
2130             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
2131 497 100       1127 if ($modifier =~ /i/oxms) {
2132 764         1386 my $uc = Ebig5hkscs::uc($char[$i]);
2133 192         368 my $fc = Ebig5hkscs::fc($char[$i]);
2134 192 50       387 if ($uc ne $fc) {
2135 192 50       367 if (CORE::length($fc) == 1) {
2136 192         357 push @singleoctet, $uc, $fc;
2137             }
2138             else {
2139 192         432 push @singleoctet, $uc;
2140 0         0 push @multipleoctet, $fc;
2141             }
2142             }
2143             else {
2144 0         0 push @singleoctet, $char[$i];
2145             }
2146             }
2147             else {
2148 0         0 push @singleoctet, $char[$i];
2149             }
2150 572         940 $i += 1;
2151             }
2152              
2153             # single character of single octet code
2154             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
2155 764         1362 push @singleoctet, "\t", "\x20";
2156 0         0 $i += 1;
2157             }
2158             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
2159 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
2160 0         0 $i += 1;
2161             }
2162             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
2163 0         0 push @singleoctet, $char[$i];
2164 2         5 $i += 1;
2165             }
2166              
2167             # single character of multiple-octet code
2168             else {
2169 2         6 push @multipleoctet, $char[$i];
2170 391         820 $i += 1;
2171             }
2172             }
2173              
2174             # quote metachar
2175 391         767 for (@singleoctet) {
2176 758 50       1554 if ($_ eq '...') {
    100          
    100          
    100          
    100          
2177 1364         6576 $_ = '-';
2178             }
2179             elsif (/\A \n \z/oxms) {
2180 0         0 $_ = '\n';
2181             }
2182             elsif (/\A \r \z/oxms) {
2183 8         19 $_ = '\r';
2184             }
2185             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
2186 8         16 $_ = sprintf('\x%02X', CORE::ord $1);
2187             }
2188             elsif (/\A [\x00-\xFF] \z/oxms) {
2189 1         6 $_ = quotemeta $_;
2190             }
2191             }
2192 939         1873 for (@multipleoctet) {
2193 758 100       1445 if (/\A ([\x80-\xFF].*) ([\x00-\xFF]) \z/oxms) {
2194 693         2033 $_ = $1 . quotemeta $2;
2195             }
2196             }
2197              
2198             # return character list
2199 307         838 return \@singleoctet, \@multipleoctet;
2200             }
2201              
2202             #
2203             # Big5-HKSCS octal escape sequence
2204             #
2205             sub octchr {
2206 758     5 0 2804 my($octdigit) = @_;
2207              
2208 5         13 my @binary = ();
2209 5         8 for my $octal (split(//,$octdigit)) {
2210             push @binary, {
2211             '0' => '000',
2212             '1' => '001',
2213             '2' => '010',
2214             '3' => '011',
2215             '4' => '100',
2216             '5' => '101',
2217             '6' => '110',
2218             '7' => '111',
2219 5         30 }->{$octal};
2220             }
2221 50         187 my $binary = join '', @binary;
2222              
2223             my $octchr = {
2224             # 1234567
2225             1 => pack('B*', "0000000$binary"),
2226             2 => pack('B*', "000000$binary"),
2227             3 => pack('B*', "00000$binary"),
2228             4 => pack('B*', "0000$binary"),
2229             5 => pack('B*', "000$binary"),
2230             6 => pack('B*', "00$binary"),
2231             7 => pack('B*', "0$binary"),
2232             0 => pack('B*', "$binary"),
2233              
2234 5         15 }->{CORE::length($binary) % 8};
2235              
2236 5         59 return $octchr;
2237             }
2238              
2239             #
2240             # Big5-HKSCS hexadecimal escape sequence
2241             #
2242             sub hexchr {
2243 5     5 0 20 my($hexdigit) = @_;
2244              
2245             my $hexchr = {
2246             1 => pack('H*', "0$hexdigit"),
2247             0 => pack('H*', "$hexdigit"),
2248              
2249 5         13 }->{CORE::length($_[0]) % 2};
2250              
2251 5         40 return $hexchr;
2252             }
2253              
2254             #
2255             # Big5-HKSCS open character list for qr
2256             #
2257             sub charlist_qr {
2258              
2259 5     519 0 18 my $modifier = pop @_;
2260 519         1029 my @char = @_;
2261              
2262 519         1397 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2263 519         1558 my @singleoctet = @$singleoctet;
2264 519         1234 my @multipleoctet = @$multipleoctet;
2265              
2266             # return character list
2267 519 100       5019 if (scalar(@singleoctet) >= 1) {
2268              
2269             # with /i modifier
2270 519 100       1362 if ($modifier =~ m/i/oxms) {
2271 384         982 my %singleoctet_ignorecase = ();
2272 107         209 for (@singleoctet) {
2273 107   100     180 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2274 272         998 for my $ord (hex($1) .. hex($2)) {
2275 80         317 my $char = CORE::chr($ord);
2276 1046         1597 my $uc = Ebig5hkscs::uc($char);
2277 1046         1484 my $fc = Ebig5hkscs::fc($char);
2278 1046 100       1700 if ($uc eq $fc) {
2279 1046         1743 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2280             }
2281             else {
2282 457 50       1250 if (CORE::length($fc) == 1) {
2283 589         836 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2284 589         1347 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2285             }
2286             else {
2287 589         1568 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2288 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2289             }
2290             }
2291             }
2292             }
2293 0 100       0 if ($_ ne '') {
2294 272         520 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2295             }
2296             }
2297 192         561 my $i = 0;
2298 107         165 my @singleoctet_ignorecase = ();
2299 107         162 for my $ord (0 .. 255) {
2300 107 100       199 if (exists $singleoctet_ignorecase{$ord}) {
2301 27392         39342 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1703  
2302             }
2303             else {
2304 1577         2818 $i++;
2305             }
2306             }
2307 25815         32674 @singleoctet = ();
2308 107         195 for my $range (@singleoctet_ignorecase) {
2309 107 100       270 if (ref $range) {
2310 11412 100       22319 if (scalar(@{$range}) == 1) {
  214 50       279  
2311 214         390 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         6  
2312             }
2313 5         52 elsif (scalar(@{$range}) == 2) {
2314 209         423 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2315             }
2316             else {
2317 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         289  
  209         295  
2318             }
2319             }
2320             }
2321             }
2322              
2323 209         1109 my $not_anchor = '';
2324 384         683 $not_anchor = '(?![\x81-\xFE])';
2325              
2326 384         699 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2327             }
2328 384 100       1276 if (scalar(@multipleoctet) >= 2) {
2329 519         1448 return '(?:' . join('|', @multipleoctet) . ')';
2330             }
2331             else {
2332 131         880 return $multipleoctet[0];
2333             }
2334             }
2335              
2336             #
2337             # Big5-HKSCS open character list for not qr
2338             #
2339             sub charlist_not_qr {
2340              
2341 388     239 0 1829 my $modifier = pop @_;
2342 239         458 my @char = @_;
2343              
2344 239         655 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2345 239         620 my @singleoctet = @$singleoctet;
2346 239         532 my @multipleoctet = @$multipleoctet;
2347              
2348             # with /i modifier
2349 239 100       411 if ($modifier =~ m/i/oxms) {
2350 239         590 my %singleoctet_ignorecase = ();
2351 128         217 for (@singleoctet) {
2352 128   100     203 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2353 272         967 for my $ord (hex($1) .. hex($2)) {
2354 80         295 my $char = CORE::chr($ord);
2355 1046         1554 my $uc = Ebig5hkscs::uc($char);
2356 1046         1511 my $fc = Ebig5hkscs::fc($char);
2357 1046 100       2041 if ($uc eq $fc) {
2358 1046         1785 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2359             }
2360             else {
2361 457 50       1264 if (CORE::length($fc) == 1) {
2362 589         839 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2363 589         1272 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2364             }
2365             else {
2366 589         1562 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2367 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2368             }
2369             }
2370             }
2371             }
2372 0 100       0 if ($_ ne '') {
2373 272         525 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2374             }
2375             }
2376 192         525 my $i = 0;
2377 128         212 my @singleoctet_ignorecase = ();
2378 128         216 for my $ord (0 .. 255) {
2379 128 100       231 if (exists $singleoctet_ignorecase{$ord}) {
2380 32768         45455 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1719  
2381             }
2382             else {
2383 1577         2779 $i++;
2384             }
2385             }
2386 31191         37807 @singleoctet = ();
2387 128         214 for my $range (@singleoctet_ignorecase) {
2388 128 100       290 if (ref $range) {
2389 11412 100       21185 if (scalar(@{$range}) == 1) {
  214 50       283  
2390 214         390 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         6  
2391             }
2392 5         57 elsif (scalar(@{$range}) == 2) {
2393 209         340 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2394             }
2395             else {
2396 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         335  
  209         302  
2397             }
2398             }
2399             }
2400             }
2401              
2402             # return character list
2403 209 100       1044 if (scalar(@multipleoctet) >= 1) {
2404 239 100       533 if (scalar(@singleoctet) >= 1) {
2405              
2406             # any character other than multiple-octet and single octet character class
2407 114         235 return '(?!' . join('|', @multipleoctet) . ')(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2408             }
2409             else {
2410              
2411             # any character other than multiple-octet character class
2412 70         546 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2413             }
2414             }
2415             else {
2416 44 50       315 if (scalar(@singleoctet) >= 1) {
2417              
2418             # any character other than single octet character class
2419 125         289 return '(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2420             }
2421             else {
2422              
2423             # any character
2424 125         755 return "(?:$your_char)";
2425             }
2426             }
2427             }
2428              
2429             #
2430             # open file in read mode
2431             #
2432             sub _open_r {
2433 0     768   0 my(undef,$file) = @_;
2434 389     389   4653 use Fcntl qw(O_RDONLY);
  389         2666  
  389         64679  
2435 768         2365 return CORE::sysopen($_[0], $file, &O_RDONLY);
2436             }
2437              
2438             #
2439             # open file in append mode
2440             #
2441             sub _open_a {
2442 768     384   32208 my(undef,$file) = @_;
2443 389     389   3064 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  389         2378  
  389         6020299  
2444 384         1131 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2445             }
2446              
2447             #
2448             # safe system
2449             #
2450             sub _systemx {
2451              
2452             # P.707 29.2.33. exec
2453             # in Chapter 29: Functions
2454             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2455             #
2456             # Be aware that in older releases of Perl, exec (and system) did not flush
2457             # your output buffer, so you needed to enable command buffering by setting $|
2458             # on one or more filehandles to avoid lost output in the case of exec, or
2459             # misordererd output in the case of system. This situation was largely remedied
2460             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2461              
2462             # P.855 exec
2463             # in Chapter 27: Functions
2464             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2465             #
2466             # In very old release of Perl (before v5.6), exec (and system) did not flush
2467             # your output buffer, so you needed to enable command buffering by setting $|
2468             # on one or more filehandles to avoid lost output with exec or misordered
2469             # output with system.
2470              
2471 384     384   68007 $| = 1;
2472              
2473             # P.565 23.1.2. Cleaning Up Your Environment
2474             # in Chapter 23: Security
2475             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2476              
2477             # P.656 Cleaning Up Your Environment
2478             # in Chapter 20: Security
2479             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2480              
2481             # local $ENV{'PATH'} = '.';
2482 384         1605 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2483              
2484             # P.707 29.2.33. exec
2485             # in Chapter 29: Functions
2486             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2487             #
2488             # As we mentioned earlier, exec treats a discrete list of arguments as an
2489             # indication that it should bypass shell processing. However, there is one
2490             # place where you might still get tripped up. The exec call (and system, too)
2491             # will not distinguish between a single scalar argument and an array containing
2492             # only one element.
2493             #
2494             # @args = ("echo surprise"); # just one element in list
2495             # exec @args # still subject to shell escapes
2496             # or die "exec: $!"; # because @args == 1
2497             #
2498             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2499             # first argument as the pathname, which forces the rest of the arguments to be
2500             # interpreted as a list, even if there is only one of them:
2501             #
2502             # exec { $args[0] } @args # safe even with one-argument list
2503             # or die "can't exec @args: $!";
2504              
2505             # P.855 exec
2506             # in Chapter 27: Functions
2507             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2508             #
2509             # As we mentioned earlier, exec treats a discrete list of arguments as a
2510             # directive to bypass shell processing. However, there is one place where
2511             # you might still get tripped up. The exec call (and system, too) cannot
2512             # distinguish between a single scalar argument and an array containing
2513             # only one element.
2514             #
2515             # @args = ("echo surprise"); # just one element in list
2516             # exec @args # still subject to shell escapes
2517             # || die "exec: $!"; # because @args == 1
2518             #
2519             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2520             # argument as the pathname, which forces the rest of the arguments to be
2521             # interpreted as a list, even if there is only one of them:
2522             #
2523             # exec { $args[0] } @args # safe even with one-argument list
2524             # || die "can't exec @args: $!";
2525              
2526 384         4314 return CORE::system { $_[0] } @_; # safe even with one-argument list
  384         911  
2527             }
2528              
2529             #
2530             # Big5-HKSCS order to character (with parameter)
2531             #
2532             sub Ebig5hkscs::chr(;$) {
2533              
2534 384 0   0 0 49929308 my $c = @_ ? $_[0] : $_;
2535              
2536 0 0       0 if ($c == 0x00) {
2537 0         0 return "\x00";
2538             }
2539             else {
2540 0         0 my @chr = ();
2541 0         0 while ($c > 0) {
2542 0         0 unshift @chr, ($c % 0x100);
2543 0         0 $c = int($c / 0x100);
2544             }
2545 0         0 return pack 'C*', @chr;
2546             }
2547             }
2548              
2549             #
2550             # Big5-HKSCS order to character (without parameter)
2551             #
2552             sub Ebig5hkscs::chr_() {
2553              
2554 0     0 0 0 my $c = $_;
2555              
2556 0 0       0 if ($c == 0x00) {
2557 0         0 return "\x00";
2558             }
2559             else {
2560 0         0 my @chr = ();
2561 0         0 while ($c > 0) {
2562 0         0 unshift @chr, ($c % 0x100);
2563 0         0 $c = int($c / 0x100);
2564             }
2565 0         0 return pack 'C*', @chr;
2566             }
2567             }
2568              
2569             #
2570             # Big5-HKSCS stacked file test expr
2571             #
2572             sub Ebig5hkscs::filetest {
2573              
2574 0     0 0 0 my $file = pop @_;
2575 0         0 my $filetest = substr(pop @_, 1);
2576              
2577 0 0       0 unless (CORE::eval qq{Ebig5hkscs::$filetest(\$file)}) {
2578 0         0 return '';
2579             }
2580 0         0 for my $filetest (CORE::reverse @_) {
2581 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
2582 0         0 return '';
2583             }
2584             }
2585 0         0 return 1;
2586             }
2587              
2588             #
2589             # Big5-HKSCS file test -r expr
2590             #
2591             sub Ebig5hkscs::r(;*@) {
2592              
2593 0 0   0 0 0 local $_ = shift if @_;
2594 0 0 0     0 croak 'Too many arguments for -r (Ebig5hkscs::r)' if @_ and not wantarray;
2595              
2596 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2597 0 0       0 return wantarray ? (-r _,@_) : -r _;
2598             }
2599              
2600             # P.908 32.39. Symbol
2601             # in Chapter 32: Standard Modules
2602             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2603              
2604             # P.326 Prototypes
2605             # in Chapter 7: Subroutines
2606             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2607              
2608             # (and so on)
2609              
2610             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2611 0 0       0 return wantarray ? (-r $fh,@_) : -r $fh;
2612             }
2613             elsif (-e $_) {
2614 0 0       0 return wantarray ? (-r _,@_) : -r _;
2615             }
2616             elsif (_MSWin32_5Cended_path($_)) {
2617 0 0       0 if (-d "$_/.") {
2618 0 0       0 return wantarray ? (-r _,@_) : -r _;
2619             }
2620             else {
2621              
2622             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Ebig5hkscs::*()
2623             # on Windows opens the file for the path which has 5c at end.
2624             # (and so on)
2625              
2626 0         0 my $fh = gensym();
2627 0 0       0 if (_open_r($fh, $_)) {
2628 0         0 my $r = -r $fh;
2629 0 0       0 close($fh) or die "Can't close file: $_: $!";
2630 0 0       0 return wantarray ? ($r,@_) : $r;
2631             }
2632             }
2633             }
2634 0 0       0 return wantarray ? (undef,@_) : undef;
2635             }
2636              
2637             #
2638             # Big5-HKSCS file test -w expr
2639             #
2640             sub Ebig5hkscs::w(;*@) {
2641              
2642 0 0   0 0 0 local $_ = shift if @_;
2643 0 0 0     0 croak 'Too many arguments for -w (Ebig5hkscs::w)' if @_ and not wantarray;
2644              
2645 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2646 0 0       0 return wantarray ? (-w _,@_) : -w _;
2647             }
2648             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2649 0 0       0 return wantarray ? (-w $fh,@_) : -w $fh;
2650             }
2651             elsif (-e $_) {
2652 0 0       0 return wantarray ? (-w _,@_) : -w _;
2653             }
2654             elsif (_MSWin32_5Cended_path($_)) {
2655 0 0       0 if (-d "$_/.") {
2656 0 0       0 return wantarray ? (-w _,@_) : -w _;
2657             }
2658             else {
2659 0         0 my $fh = gensym();
2660 0 0       0 if (_open_a($fh, $_)) {
2661 0         0 my $w = -w $fh;
2662 0 0       0 close($fh) or die "Can't close file: $_: $!";
2663 0 0       0 return wantarray ? ($w,@_) : $w;
2664             }
2665             }
2666             }
2667 0 0       0 return wantarray ? (undef,@_) : undef;
2668             }
2669              
2670             #
2671             # Big5-HKSCS file test -x expr
2672             #
2673             sub Ebig5hkscs::x(;*@) {
2674              
2675 0 0   0 0 0 local $_ = shift if @_;
2676 0 0 0     0 croak 'Too many arguments for -x (Ebig5hkscs::x)' if @_ and not wantarray;
2677              
2678 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2679 0 0       0 return wantarray ? (-x _,@_) : -x _;
2680             }
2681             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2682 0 0       0 return wantarray ? (-x $fh,@_) : -x $fh;
2683             }
2684             elsif (-e $_) {
2685 0 0       0 return wantarray ? (-x _,@_) : -x _;
2686             }
2687             elsif (_MSWin32_5Cended_path($_)) {
2688 0 0       0 if (-d "$_/.") {
2689 0 0       0 return wantarray ? (-x _,@_) : -x _;
2690             }
2691             else {
2692 0         0 my $fh = gensym();
2693 0 0       0 if (_open_r($fh, $_)) {
2694 0         0 my $dummy_for_underline_cache = -x $fh;
2695 0 0       0 close($fh) or die "Can't close file: $_: $!";
2696             }
2697              
2698             # filename is not .COM .EXE .BAT .CMD
2699 0 0       0 return wantarray ? ('',@_) : '';
2700             }
2701             }
2702 0 0       0 return wantarray ? (undef,@_) : undef;
2703             }
2704              
2705             #
2706             # Big5-HKSCS file test -o expr
2707             #
2708             sub Ebig5hkscs::o(;*@) {
2709              
2710 0 0   0 0 0 local $_ = shift if @_;
2711 0 0 0     0 croak 'Too many arguments for -o (Ebig5hkscs::o)' if @_ and not wantarray;
2712              
2713 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2714 0 0       0 return wantarray ? (-o _,@_) : -o _;
2715             }
2716             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2717 0 0       0 return wantarray ? (-o $fh,@_) : -o $fh;
2718             }
2719             elsif (-e $_) {
2720 0 0       0 return wantarray ? (-o _,@_) : -o _;
2721             }
2722             elsif (_MSWin32_5Cended_path($_)) {
2723 0 0       0 if (-d "$_/.") {
2724 0 0       0 return wantarray ? (-o _,@_) : -o _;
2725             }
2726             else {
2727 0         0 my $fh = gensym();
2728 0 0       0 if (_open_r($fh, $_)) {
2729 0         0 my $o = -o $fh;
2730 0 0       0 close($fh) or die "Can't close file: $_: $!";
2731 0 0       0 return wantarray ? ($o,@_) : $o;
2732             }
2733             }
2734             }
2735 0 0       0 return wantarray ? (undef,@_) : undef;
2736             }
2737              
2738             #
2739             # Big5-HKSCS file test -R expr
2740             #
2741             sub Ebig5hkscs::R(;*@) {
2742              
2743 0 0   0 0 0 local $_ = shift if @_;
2744 0 0 0     0 croak 'Too many arguments for -R (Ebig5hkscs::R)' if @_ and not wantarray;
2745              
2746 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2747 0 0       0 return wantarray ? (-R _,@_) : -R _;
2748             }
2749             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2750 0 0       0 return wantarray ? (-R $fh,@_) : -R $fh;
2751             }
2752             elsif (-e $_) {
2753 0 0       0 return wantarray ? (-R _,@_) : -R _;
2754             }
2755             elsif (_MSWin32_5Cended_path($_)) {
2756 0 0       0 if (-d "$_/.") {
2757 0 0       0 return wantarray ? (-R _,@_) : -R _;
2758             }
2759             else {
2760 0         0 my $fh = gensym();
2761 0 0       0 if (_open_r($fh, $_)) {
2762 0         0 my $R = -R $fh;
2763 0 0       0 close($fh) or die "Can't close file: $_: $!";
2764 0 0       0 return wantarray ? ($R,@_) : $R;
2765             }
2766             }
2767             }
2768 0 0       0 return wantarray ? (undef,@_) : undef;
2769             }
2770              
2771             #
2772             # Big5-HKSCS file test -W expr
2773             #
2774             sub Ebig5hkscs::W(;*@) {
2775              
2776 0 0   0 0 0 local $_ = shift if @_;
2777 0 0 0     0 croak 'Too many arguments for -W (Ebig5hkscs::W)' if @_ and not wantarray;
2778              
2779 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2780 0 0       0 return wantarray ? (-W _,@_) : -W _;
2781             }
2782             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2783 0 0       0 return wantarray ? (-W $fh,@_) : -W $fh;
2784             }
2785             elsif (-e $_) {
2786 0 0       0 return wantarray ? (-W _,@_) : -W _;
2787             }
2788             elsif (_MSWin32_5Cended_path($_)) {
2789 0 0       0 if (-d "$_/.") {
2790 0 0       0 return wantarray ? (-W _,@_) : -W _;
2791             }
2792             else {
2793 0         0 my $fh = gensym();
2794 0 0       0 if (_open_a($fh, $_)) {
2795 0         0 my $W = -W $fh;
2796 0 0       0 close($fh) or die "Can't close file: $_: $!";
2797 0 0       0 return wantarray ? ($W,@_) : $W;
2798             }
2799             }
2800             }
2801 0 0       0 return wantarray ? (undef,@_) : undef;
2802             }
2803              
2804             #
2805             # Big5-HKSCS file test -X expr
2806             #
2807             sub Ebig5hkscs::X(;*@) {
2808              
2809 0 0   0 1 0 local $_ = shift if @_;
2810 0 0 0     0 croak 'Too many arguments for -X (Ebig5hkscs::X)' if @_ and not wantarray;
2811              
2812 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2813 0 0       0 return wantarray ? (-X _,@_) : -X _;
2814             }
2815             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2816 0 0       0 return wantarray ? (-X $fh,@_) : -X $fh;
2817             }
2818             elsif (-e $_) {
2819 0 0       0 return wantarray ? (-X _,@_) : -X _;
2820             }
2821             elsif (_MSWin32_5Cended_path($_)) {
2822 0 0       0 if (-d "$_/.") {
2823 0 0       0 return wantarray ? (-X _,@_) : -X _;
2824             }
2825             else {
2826 0         0 my $fh = gensym();
2827 0 0       0 if (_open_r($fh, $_)) {
2828 0         0 my $dummy_for_underline_cache = -X $fh;
2829 0 0       0 close($fh) or die "Can't close file: $_: $!";
2830             }
2831              
2832             # filename is not .COM .EXE .BAT .CMD
2833 0 0       0 return wantarray ? ('',@_) : '';
2834             }
2835             }
2836 0 0       0 return wantarray ? (undef,@_) : undef;
2837             }
2838              
2839             #
2840             # Big5-HKSCS file test -O expr
2841             #
2842             sub Ebig5hkscs::O(;*@) {
2843              
2844 0 0   0 0 0 local $_ = shift if @_;
2845 0 0 0     0 croak 'Too many arguments for -O (Ebig5hkscs::O)' if @_ and not wantarray;
2846              
2847 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2848 0 0       0 return wantarray ? (-O _,@_) : -O _;
2849             }
2850             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2851 0 0       0 return wantarray ? (-O $fh,@_) : -O $fh;
2852             }
2853             elsif (-e $_) {
2854 0 0       0 return wantarray ? (-O _,@_) : -O _;
2855             }
2856             elsif (_MSWin32_5Cended_path($_)) {
2857 0 0       0 if (-d "$_/.") {
2858 0 0       0 return wantarray ? (-O _,@_) : -O _;
2859             }
2860             else {
2861 0         0 my $fh = gensym();
2862 0 0       0 if (_open_r($fh, $_)) {
2863 0         0 my $O = -O $fh;
2864 0 0       0 close($fh) or die "Can't close file: $_: $!";
2865 0 0       0 return wantarray ? ($O,@_) : $O;
2866             }
2867             }
2868             }
2869 0 0       0 return wantarray ? (undef,@_) : undef;
2870             }
2871              
2872             #
2873             # Big5-HKSCS file test -e expr
2874             #
2875             sub Ebig5hkscs::e(;*@) {
2876              
2877 0 50   768 0 0 local $_ = shift if @_;
2878 768 50 33     3066 croak 'Too many arguments for -e (Ebig5hkscs::e)' if @_ and not wantarray;
2879              
2880 768         3268 local $^W = 0;
2881              
2882 768         2628 my $fh = qualify_to_ref $_;
2883 768 50       2181 if ($_ eq '_') {
    50          
    50          
    50          
    50          
2884 768 0       3609 return wantarray ? (-e _,@_) : -e _;
2885             }
2886              
2887             # return false if directory handle
2888             elsif (defined Ebig5hkscs::telldir($fh)) {
2889 0 0       0 return wantarray ? ('',@_) : '';
2890             }
2891              
2892             # return true if file handle
2893             elsif (defined fileno $fh) {
2894 0 0       0 return wantarray ? (1,@_) : 1;
2895             }
2896              
2897             elsif (-e $_) {
2898 0 0       0 return wantarray ? (1,@_) : 1;
2899             }
2900             elsif (_MSWin32_5Cended_path($_)) {
2901 0 0       0 if (-d "$_/.") {
2902 0 0       0 return wantarray ? (1,@_) : 1;
2903             }
2904             else {
2905 0         0 my $fh = gensym();
2906 0 0       0 if (_open_r($fh, $_)) {
2907 0         0 my $e = -e $fh;
2908 0 0       0 close($fh) or die "Can't close file: $_: $!";
2909 0 0       0 return wantarray ? ($e,@_) : $e;
2910             }
2911             }
2912             }
2913 0 50       0 return wantarray ? (undef,@_) : undef;
2914             }
2915              
2916             #
2917             # Big5-HKSCS file test -z expr
2918             #
2919             sub Ebig5hkscs::z(;*@) {
2920              
2921 768 0   0 0 4237 local $_ = shift if @_;
2922 0 0 0     0 croak 'Too many arguments for -z (Ebig5hkscs::z)' if @_ and not wantarray;
2923              
2924 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2925 0 0       0 return wantarray ? (-z _,@_) : -z _;
2926             }
2927             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2928 0 0       0 return wantarray ? (-z $fh,@_) : -z $fh;
2929             }
2930             elsif (-e $_) {
2931 0 0       0 return wantarray ? (-z _,@_) : -z _;
2932             }
2933             elsif (_MSWin32_5Cended_path($_)) {
2934 0 0       0 if (-d "$_/.") {
2935 0 0       0 return wantarray ? (-z _,@_) : -z _;
2936             }
2937             else {
2938 0         0 my $fh = gensym();
2939 0 0       0 if (_open_r($fh, $_)) {
2940 0         0 my $z = -z $fh;
2941 0 0       0 close($fh) or die "Can't close file: $_: $!";
2942 0 0       0 return wantarray ? ($z,@_) : $z;
2943             }
2944             }
2945             }
2946 0 0       0 return wantarray ? (undef,@_) : undef;
2947             }
2948              
2949             #
2950             # Big5-HKSCS file test -s expr
2951             #
2952             sub Ebig5hkscs::s(;*@) {
2953              
2954 0 0   0 0 0 local $_ = shift if @_;
2955 0 0 0     0 croak 'Too many arguments for -s (Ebig5hkscs::s)' if @_ and not wantarray;
2956              
2957 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2958 0 0       0 return wantarray ? (-s _,@_) : -s _;
2959             }
2960             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2961 0 0       0 return wantarray ? (-s $fh,@_) : -s $fh;
2962             }
2963             elsif (-e $_) {
2964 0 0       0 return wantarray ? (-s _,@_) : -s _;
2965             }
2966             elsif (_MSWin32_5Cended_path($_)) {
2967 0 0       0 if (-d "$_/.") {
2968 0 0       0 return wantarray ? (-s _,@_) : -s _;
2969             }
2970             else {
2971 0         0 my $fh = gensym();
2972 0 0       0 if (_open_r($fh, $_)) {
2973 0         0 my $s = -s $fh;
2974 0 0       0 close($fh) or die "Can't close file: $_: $!";
2975 0 0       0 return wantarray ? ($s,@_) : $s;
2976             }
2977             }
2978             }
2979 0 0       0 return wantarray ? (undef,@_) : undef;
2980             }
2981              
2982             #
2983             # Big5-HKSCS file test -f expr
2984             #
2985             sub Ebig5hkscs::f(;*@) {
2986              
2987 0 0   0 0 0 local $_ = shift if @_;
2988 0 0 0     0 croak 'Too many arguments for -f (Ebig5hkscs::f)' if @_ and not wantarray;
2989              
2990 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2991 0 0       0 return wantarray ? (-f _,@_) : -f _;
2992             }
2993             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2994 0 0       0 return wantarray ? (-f $fh,@_) : -f $fh;
2995             }
2996             elsif (-e $_) {
2997 0 0       0 return wantarray ? (-f _,@_) : -f _;
2998             }
2999             elsif (_MSWin32_5Cended_path($_)) {
3000 0 0       0 if (-d "$_/.") {
3001 0 0       0 return wantarray ? ('',@_) : '';
3002             }
3003             else {
3004 0         0 my $fh = gensym();
3005 0 0       0 if (_open_r($fh, $_)) {
3006 0         0 my $f = -f $fh;
3007 0 0       0 close($fh) or die "Can't close file: $_: $!";
3008 0 0       0 return wantarray ? ($f,@_) : $f;
3009             }
3010             }
3011             }
3012 0 0       0 return wantarray ? (undef,@_) : undef;
3013             }
3014              
3015             #
3016             # Big5-HKSCS file test -d expr
3017             #
3018             sub Ebig5hkscs::d(;*@) {
3019              
3020 0 0   0 0 0 local $_ = shift if @_;
3021 0 0 0     0 croak 'Too many arguments for -d (Ebig5hkscs::d)' if @_ and not wantarray;
3022              
3023 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3024 0 0       0 return wantarray ? (-d _,@_) : -d _;
3025             }
3026              
3027             # return false if file handle or directory handle
3028             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3029 0 0       0 return wantarray ? ('',@_) : '';
3030             }
3031             elsif (-e $_) {
3032 0 0       0 return wantarray ? (-d _,@_) : -d _;
3033             }
3034             elsif (_MSWin32_5Cended_path($_)) {
3035 0 0       0 return wantarray ? (-d "$_/.",@_) : -d "$_/.";
3036             }
3037 0 0       0 return wantarray ? (undef,@_) : undef;
3038             }
3039              
3040             #
3041             # Big5-HKSCS file test -l expr
3042             #
3043             sub Ebig5hkscs::l(;*@) {
3044              
3045 0 0   0 0 0 local $_ = shift if @_;
3046 0 0 0     0 croak 'Too many arguments for -l (Ebig5hkscs::l)' if @_ and not wantarray;
3047              
3048 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3049 0 0       0 return wantarray ? (-l _,@_) : -l _;
3050             }
3051             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3052 0 0       0 return wantarray ? (-l $fh,@_) : -l $fh;
3053             }
3054             elsif (-e $_) {
3055 0 0       0 return wantarray ? (-l _,@_) : -l _;
3056             }
3057             elsif (_MSWin32_5Cended_path($_)) {
3058 0 0       0 if (-d "$_/.") {
3059 0 0       0 return wantarray ? (-l _,@_) : -l _;
3060             }
3061             else {
3062 0         0 my $fh = gensym();
3063 0 0       0 if (_open_r($fh, $_)) {
3064 0         0 my $l = -l $fh;
3065 0 0       0 close($fh) or die "Can't close file: $_: $!";
3066 0 0       0 return wantarray ? ($l,@_) : $l;
3067             }
3068             }
3069             }
3070 0 0       0 return wantarray ? (undef,@_) : undef;
3071             }
3072              
3073             #
3074             # Big5-HKSCS file test -p expr
3075             #
3076             sub Ebig5hkscs::p(;*@) {
3077              
3078 0 0   0 0 0 local $_ = shift if @_;
3079 0 0 0     0 croak 'Too many arguments for -p (Ebig5hkscs::p)' if @_ and not wantarray;
3080              
3081 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3082 0 0       0 return wantarray ? (-p _,@_) : -p _;
3083             }
3084             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3085 0 0       0 return wantarray ? (-p $fh,@_) : -p $fh;
3086             }
3087             elsif (-e $_) {
3088 0 0       0 return wantarray ? (-p _,@_) : -p _;
3089             }
3090             elsif (_MSWin32_5Cended_path($_)) {
3091 0 0       0 if (-d "$_/.") {
3092 0 0       0 return wantarray ? (-p _,@_) : -p _;
3093             }
3094             else {
3095 0         0 my $fh = gensym();
3096 0 0       0 if (_open_r($fh, $_)) {
3097 0         0 my $p = -p $fh;
3098 0 0       0 close($fh) or die "Can't close file: $_: $!";
3099 0 0       0 return wantarray ? ($p,@_) : $p;
3100             }
3101             }
3102             }
3103 0 0       0 return wantarray ? (undef,@_) : undef;
3104             }
3105              
3106             #
3107             # Big5-HKSCS file test -S expr
3108             #
3109             sub Ebig5hkscs::S(;*@) {
3110              
3111 0 0   0 0 0 local $_ = shift if @_;
3112 0 0 0     0 croak 'Too many arguments for -S (Ebig5hkscs::S)' if @_ and not wantarray;
3113              
3114 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3115 0 0       0 return wantarray ? (-S _,@_) : -S _;
3116             }
3117             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3118 0 0       0 return wantarray ? (-S $fh,@_) : -S $fh;
3119             }
3120             elsif (-e $_) {
3121 0 0       0 return wantarray ? (-S _,@_) : -S _;
3122             }
3123             elsif (_MSWin32_5Cended_path($_)) {
3124 0 0       0 if (-d "$_/.") {
3125 0 0       0 return wantarray ? (-S _,@_) : -S _;
3126             }
3127             else {
3128 0         0 my $fh = gensym();
3129 0 0       0 if (_open_r($fh, $_)) {
3130 0         0 my $S = -S $fh;
3131 0 0       0 close($fh) or die "Can't close file: $_: $!";
3132 0 0       0 return wantarray ? ($S,@_) : $S;
3133             }
3134             }
3135             }
3136 0 0       0 return wantarray ? (undef,@_) : undef;
3137             }
3138              
3139             #
3140             # Big5-HKSCS file test -b expr
3141             #
3142             sub Ebig5hkscs::b(;*@) {
3143              
3144 0 0   0 0 0 local $_ = shift if @_;
3145 0 0 0     0 croak 'Too many arguments for -b (Ebig5hkscs::b)' if @_ and not wantarray;
3146              
3147 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3148 0 0       0 return wantarray ? (-b _,@_) : -b _;
3149             }
3150             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3151 0 0       0 return wantarray ? (-b $fh,@_) : -b $fh;
3152             }
3153             elsif (-e $_) {
3154 0 0       0 return wantarray ? (-b _,@_) : -b _;
3155             }
3156             elsif (_MSWin32_5Cended_path($_)) {
3157 0 0       0 if (-d "$_/.") {
3158 0 0       0 return wantarray ? (-b _,@_) : -b _;
3159             }
3160             else {
3161 0         0 my $fh = gensym();
3162 0 0       0 if (_open_r($fh, $_)) {
3163 0         0 my $b = -b $fh;
3164 0 0       0 close($fh) or die "Can't close file: $_: $!";
3165 0 0       0 return wantarray ? ($b,@_) : $b;
3166             }
3167             }
3168             }
3169 0 0       0 return wantarray ? (undef,@_) : undef;
3170             }
3171              
3172             #
3173             # Big5-HKSCS file test -c expr
3174             #
3175             sub Ebig5hkscs::c(;*@) {
3176              
3177 0 0   0 0 0 local $_ = shift if @_;
3178 0 0 0     0 croak 'Too many arguments for -c (Ebig5hkscs::c)' if @_ and not wantarray;
3179              
3180 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3181 0 0       0 return wantarray ? (-c _,@_) : -c _;
3182             }
3183             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3184 0 0       0 return wantarray ? (-c $fh,@_) : -c $fh;
3185             }
3186             elsif (-e $_) {
3187 0 0       0 return wantarray ? (-c _,@_) : -c _;
3188             }
3189             elsif (_MSWin32_5Cended_path($_)) {
3190 0 0       0 if (-d "$_/.") {
3191 0 0       0 return wantarray ? (-c _,@_) : -c _;
3192             }
3193             else {
3194 0         0 my $fh = gensym();
3195 0 0       0 if (_open_r($fh, $_)) {
3196 0         0 my $c = -c $fh;
3197 0 0       0 close($fh) or die "Can't close file: $_: $!";
3198 0 0       0 return wantarray ? ($c,@_) : $c;
3199             }
3200             }
3201             }
3202 0 0       0 return wantarray ? (undef,@_) : undef;
3203             }
3204              
3205             #
3206             # Big5-HKSCS file test -u expr
3207             #
3208             sub Ebig5hkscs::u(;*@) {
3209              
3210 0 0   0 0 0 local $_ = shift if @_;
3211 0 0 0     0 croak 'Too many arguments for -u (Ebig5hkscs::u)' if @_ and not wantarray;
3212              
3213 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3214 0 0       0 return wantarray ? (-u _,@_) : -u _;
3215             }
3216             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3217 0 0       0 return wantarray ? (-u $fh,@_) : -u $fh;
3218             }
3219             elsif (-e $_) {
3220 0 0       0 return wantarray ? (-u _,@_) : -u _;
3221             }
3222             elsif (_MSWin32_5Cended_path($_)) {
3223 0 0       0 if (-d "$_/.") {
3224 0 0       0 return wantarray ? (-u _,@_) : -u _;
3225             }
3226             else {
3227 0         0 my $fh = gensym();
3228 0 0       0 if (_open_r($fh, $_)) {
3229 0         0 my $u = -u $fh;
3230 0 0       0 close($fh) or die "Can't close file: $_: $!";
3231 0 0       0 return wantarray ? ($u,@_) : $u;
3232             }
3233             }
3234             }
3235 0 0       0 return wantarray ? (undef,@_) : undef;
3236             }
3237              
3238             #
3239             # Big5-HKSCS file test -g expr
3240             #
3241             sub Ebig5hkscs::g(;*@) {
3242              
3243 0 0   0 0 0 local $_ = shift if @_;
3244 0 0 0     0 croak 'Too many arguments for -g (Ebig5hkscs::g)' if @_ and not wantarray;
3245              
3246 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3247 0 0       0 return wantarray ? (-g _,@_) : -g _;
3248             }
3249             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3250 0 0       0 return wantarray ? (-g $fh,@_) : -g $fh;
3251             }
3252             elsif (-e $_) {
3253 0 0       0 return wantarray ? (-g _,@_) : -g _;
3254             }
3255             elsif (_MSWin32_5Cended_path($_)) {
3256 0 0       0 if (-d "$_/.") {
3257 0 0       0 return wantarray ? (-g _,@_) : -g _;
3258             }
3259             else {
3260 0         0 my $fh = gensym();
3261 0 0       0 if (_open_r($fh, $_)) {
3262 0         0 my $g = -g $fh;
3263 0 0       0 close($fh) or die "Can't close file: $_: $!";
3264 0 0       0 return wantarray ? ($g,@_) : $g;
3265             }
3266             }
3267             }
3268 0 0       0 return wantarray ? (undef,@_) : undef;
3269             }
3270              
3271             #
3272             # Big5-HKSCS file test -k expr
3273             #
3274             sub Ebig5hkscs::k(;*@) {
3275              
3276 0 0   0 0 0 local $_ = shift if @_;
3277 0 0 0     0 croak 'Too many arguments for -k (Ebig5hkscs::k)' if @_ and not wantarray;
3278              
3279 0 0       0 if ($_ eq '_') {
    0          
    0          
3280 0 0       0 return wantarray ? ('',@_) : '';
3281             }
3282             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3283 0 0       0 return wantarray ? ('',@_) : '';
3284             }
3285             elsif ($] =~ /^5\.008/oxms) {
3286 0 0       0 return wantarray ? ('',@_) : '';
3287             }
3288 0 0       0 return wantarray ? ($_,@_) : $_;
3289             }
3290              
3291             #
3292             # Big5-HKSCS file test -T expr
3293             #
3294             sub Ebig5hkscs::T(;*@) {
3295              
3296 0 0   0 0 0 local $_ = shift if @_;
3297              
3298             # Use of croak without parentheses makes die on Strawberry Perl 5.008 and 5.010, like:
3299             # croak 'Too many arguments for -T (Ebig5hkscs::T)';
3300             # Must be used by parentheses like:
3301             # croak('Too many arguments for -T (Ebig5hkscs::T)');
3302              
3303 0 0 0     0 if (@_ and not wantarray) {
3304 0         0 croak('Too many arguments for -T (Ebig5hkscs::T)');
3305             }
3306              
3307 0         0 my $T = 1;
3308              
3309 0         0 my $fh = qualify_to_ref $_;
3310 0 0       0 if (defined fileno $fh) {
3311              
3312 0 0       0 if (defined Ebig5hkscs::telldir($fh)) {
3313 0 0       0 return wantarray ? (undef,@_) : undef;
3314             }
3315              
3316             # P.813 29.2.176. tell
3317             # in Chapter 29: Functions
3318             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3319              
3320             # P.970 tell
3321             # in Chapter 27: Functions
3322             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3323              
3324             # (and so on)
3325              
3326 0         0 my $systell = sysseek $fh, 0, 1;
3327              
3328 0 0       0 if (sysread $fh, my $block, 512) {
3329              
3330             # P.163 Binary file check in Little Perl Parlor 16
3331             # of Book No. T1008901080816 ZASSHI 08901-8 UNIX MAGAZINE 1993 Aug VOL8#8
3332             # (and so on)
3333              
3334 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3335 0         0 $T = '';
3336             }
3337             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3338 0         0 $T = '';
3339             }
3340             }
3341              
3342             # 0 byte or eof
3343             else {
3344 0         0 $T = 1;
3345             }
3346              
3347 0         0 my $dummy_for_underline_cache = -T $fh;
3348 0         0 sysseek $fh, $systell, 0;
3349             }
3350             else {
3351 0 0 0     0 if (-d $_ or -d "$_/.") {
3352 0 0       0 return wantarray ? (undef,@_) : undef;
3353             }
3354              
3355 0         0 $fh = gensym();
3356 0 0       0 if (_open_r($fh, $_)) {
3357             }
3358             else {
3359 0 0       0 return wantarray ? (undef,@_) : undef;
3360             }
3361 0 0       0 if (sysread $fh, my $block, 512) {
3362 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3363 0         0 $T = '';
3364             }
3365             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3366 0         0 $T = '';
3367             }
3368             }
3369              
3370             # 0 byte or eof
3371             else {
3372 0         0 $T = 1;
3373             }
3374 0         0 my $dummy_for_underline_cache = -T $fh;
3375 0 0       0 close($fh) or die "Can't close file: $_: $!";
3376             }
3377              
3378 0 0       0 return wantarray ? ($T,@_) : $T;
3379             }
3380              
3381             #
3382             # Big5-HKSCS file test -B expr
3383             #
3384             sub Ebig5hkscs::B(;*@) {
3385              
3386 0 0   0 0 0 local $_ = shift if @_;
3387 0 0 0     0 croak 'Too many arguments for -B (Ebig5hkscs::B)' if @_ and not wantarray;
3388 0         0 my $B = '';
3389              
3390 0         0 my $fh = qualify_to_ref $_;
3391 0 0       0 if (defined fileno $fh) {
3392              
3393 0 0       0 if (defined Ebig5hkscs::telldir($fh)) {
3394 0 0       0 return wantarray ? (undef,@_) : undef;
3395             }
3396              
3397 0         0 my $systell = sysseek $fh, 0, 1;
3398              
3399 0 0       0 if (sysread $fh, my $block, 512) {
3400 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3401 0         0 $B = 1;
3402             }
3403             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3404 0         0 $B = 1;
3405             }
3406             }
3407              
3408             # 0 byte or eof
3409             else {
3410 0         0 $B = 1;
3411             }
3412              
3413 0         0 my $dummy_for_underline_cache = -B $fh;
3414 0         0 sysseek $fh, $systell, 0;
3415             }
3416             else {
3417 0 0 0     0 if (-d $_ or -d "$_/.") {
3418 0 0       0 return wantarray ? (undef,@_) : undef;
3419             }
3420              
3421 0         0 $fh = gensym();
3422 0 0       0 if (_open_r($fh, $_)) {
3423             }
3424             else {
3425 0 0       0 return wantarray ? (undef,@_) : undef;
3426             }
3427 0 0       0 if (sysread $fh, my $block, 512) {
3428 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3429 0         0 $B = 1;
3430             }
3431             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3432 0         0 $B = 1;
3433             }
3434             }
3435              
3436             # 0 byte or eof
3437             else {
3438 0         0 $B = 1;
3439             }
3440 0         0 my $dummy_for_underline_cache = -B $fh;
3441 0 0       0 close($fh) or die "Can't close file: $_: $!";
3442             }
3443              
3444 0 0       0 return wantarray ? ($B,@_) : $B;
3445             }
3446              
3447             #
3448             # Big5-HKSCS file test -M expr
3449             #
3450             sub Ebig5hkscs::M(;*@) {
3451              
3452 0 0   0 0 0 local $_ = shift if @_;
3453 0 0 0     0 croak 'Too many arguments for -M (Ebig5hkscs::M)' if @_ and not wantarray;
3454              
3455 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3456 0 0       0 return wantarray ? (-M _,@_) : -M _;
3457             }
3458             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3459 0 0       0 return wantarray ? (-M $fh,@_) : -M $fh;
3460             }
3461             elsif (-e $_) {
3462 0 0       0 return wantarray ? (-M _,@_) : -M _;
3463             }
3464             elsif (_MSWin32_5Cended_path($_)) {
3465 0 0       0 if (-d "$_/.") {
3466 0 0       0 return wantarray ? (-M _,@_) : -M _;
3467             }
3468             else {
3469 0         0 my $fh = gensym();
3470 0 0       0 if (_open_r($fh, $_)) {
3471 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3472 0 0       0 close($fh) or die "Can't close file: $_: $!";
3473 0         0 my $M = ($^T - $mtime) / (24*60*60);
3474 0 0       0 return wantarray ? ($M,@_) : $M;
3475             }
3476             }
3477             }
3478 0 0       0 return wantarray ? (undef,@_) : undef;
3479             }
3480              
3481             #
3482             # Big5-HKSCS file test -A expr
3483             #
3484             sub Ebig5hkscs::A(;*@) {
3485              
3486 0 0   0 0 0 local $_ = shift if @_;
3487 0 0 0     0 croak 'Too many arguments for -A (Ebig5hkscs::A)' if @_ and not wantarray;
3488              
3489 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3490 0 0       0 return wantarray ? (-A _,@_) : -A _;
3491             }
3492             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3493 0 0       0 return wantarray ? (-A $fh,@_) : -A $fh;
3494             }
3495             elsif (-e $_) {
3496 0 0       0 return wantarray ? (-A _,@_) : -A _;
3497             }
3498             elsif (_MSWin32_5Cended_path($_)) {
3499 0 0       0 if (-d "$_/.") {
3500 0 0       0 return wantarray ? (-A _,@_) : -A _;
3501             }
3502             else {
3503 0         0 my $fh = gensym();
3504 0 0       0 if (_open_r($fh, $_)) {
3505 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3506 0 0       0 close($fh) or die "Can't close file: $_: $!";
3507 0         0 my $A = ($^T - $atime) / (24*60*60);
3508 0 0       0 return wantarray ? ($A,@_) : $A;
3509             }
3510             }
3511             }
3512 0 0       0 return wantarray ? (undef,@_) : undef;
3513             }
3514              
3515             #
3516             # Big5-HKSCS file test -C expr
3517             #
3518             sub Ebig5hkscs::C(;*@) {
3519              
3520 0 0   0 0 0 local $_ = shift if @_;
3521 0 0 0     0 croak 'Too many arguments for -C (Ebig5hkscs::C)' if @_ and not wantarray;
3522              
3523 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3524 0 0       0 return wantarray ? (-C _,@_) : -C _;
3525             }
3526             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3527 0 0       0 return wantarray ? (-C $fh,@_) : -C $fh;
3528             }
3529             elsif (-e $_) {
3530 0 0       0 return wantarray ? (-C _,@_) : -C _;
3531             }
3532             elsif (_MSWin32_5Cended_path($_)) {
3533 0 0       0 if (-d "$_/.") {
3534 0 0       0 return wantarray ? (-C _,@_) : -C _;
3535             }
3536             else {
3537 0         0 my $fh = gensym();
3538 0 0       0 if (_open_r($fh, $_)) {
3539 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3540 0 0       0 close($fh) or die "Can't close file: $_: $!";
3541 0         0 my $C = ($^T - $ctime) / (24*60*60);
3542 0 0       0 return wantarray ? ($C,@_) : $C;
3543             }
3544             }
3545             }
3546 0 0       0 return wantarray ? (undef,@_) : undef;
3547             }
3548              
3549             #
3550             # Big5-HKSCS stacked file test $_
3551             #
3552             sub Ebig5hkscs::filetest_ {
3553              
3554 0     0 0 0 my $filetest = substr(pop @_, 1);
3555              
3556 0 0       0 unless (CORE::eval qq{Ebig5hkscs::${filetest}_}) {
3557 0         0 return '';
3558             }
3559 0         0 for my $filetest (CORE::reverse @_) {
3560 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
3561 0         0 return '';
3562             }
3563             }
3564 0         0 return 1;
3565             }
3566              
3567             #
3568             # Big5-HKSCS file test -r $_
3569             #
3570             sub Ebig5hkscs::r_() {
3571              
3572 0 0   0 0 0 if (-e $_) {
    0          
3573 0 0       0 return -r _ ? 1 : '';
3574             }
3575             elsif (_MSWin32_5Cended_path($_)) {
3576 0 0       0 if (-d "$_/.") {
3577 0 0       0 return -r _ ? 1 : '';
3578             }
3579             else {
3580 0         0 my $fh = gensym();
3581 0 0       0 if (_open_r($fh, $_)) {
3582 0         0 my $r = -r $fh;
3583 0 0       0 close($fh) or die "Can't close file: $_: $!";
3584 0 0       0 return $r ? 1 : '';
3585             }
3586             }
3587             }
3588              
3589             # 10.10. Returning Failure
3590             # in Chapter 10. Subroutines
3591             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3592             # (and so on)
3593              
3594             # 2010-01-26 The difference of "return;" and "return undef;"
3595             # http://d.hatena.ne.jp/gfx/20100126/1264474754
3596             #
3597             # "Perl Best Practices" recommends to use "return;"*1 to return nothing, but
3598             # it might be wrong in some cases. If you use this idiom for those functions
3599             # which are expected to return a scalar value, e.g. searching functions, the
3600             # user of those functions will be surprised at what they return in list
3601             # context, an empty list - note that many functions and all the methods
3602             # evaluate their arguments in list context. You'd better to use "return undef;"
3603             # for such scalar functions.
3604             #
3605             # sub search_something {
3606             # my($arg) = @_;
3607             # # search_something...
3608             # if(defined $found){
3609             # return $found;
3610             # }
3611             # return; # XXX: you'd better to "return undef;"
3612             # }
3613             #
3614             # # ...
3615             #
3616             # # you'll get what you want, but ...
3617             # my $something = search_something($source);
3618             #
3619             # # you won't get what you want here.
3620             # # @_ for doit() is (-foo => $opt), not (undef, -foo => $opt).
3621             # $obj->doit(search_something($source), -option=> $optval);
3622             #
3623             # # you have to use the "scalar" operator in such a case.
3624             # $obj->doit(scalar search_something($source), ...);
3625             #
3626             # *1: it returns an empty list in list context, or returns undef in scalar
3627             # context
3628             #
3629             # (and so on)
3630              
3631 0         0 return undef;
3632             }
3633              
3634             #
3635             # Big5-HKSCS file test -w $_
3636             #
3637             sub Ebig5hkscs::w_() {
3638              
3639 0 0   0 0 0 if (-e $_) {
    0          
3640 0 0       0 return -w _ ? 1 : '';
3641             }
3642             elsif (_MSWin32_5Cended_path($_)) {
3643 0 0       0 if (-d "$_/.") {
3644 0 0       0 return -w _ ? 1 : '';
3645             }
3646             else {
3647 0         0 my $fh = gensym();
3648 0 0       0 if (_open_a($fh, $_)) {
3649 0         0 my $w = -w $fh;
3650 0 0       0 close($fh) or die "Can't close file: $_: $!";
3651 0 0       0 return $w ? 1 : '';
3652             }
3653             }
3654             }
3655 0         0 return undef;
3656             }
3657              
3658             #
3659             # Big5-HKSCS file test -x $_
3660             #
3661             sub Ebig5hkscs::x_() {
3662              
3663 0 0   0 0 0 if (-e $_) {
    0          
3664 0 0       0 return -x _ ? 1 : '';
3665             }
3666             elsif (_MSWin32_5Cended_path($_)) {
3667 0 0       0 if (-d "$_/.") {
3668 0 0       0 return -x _ ? 1 : '';
3669             }
3670             else {
3671 0         0 my $fh = gensym();
3672 0 0       0 if (_open_r($fh, $_)) {
3673 0         0 my $dummy_for_underline_cache = -x $fh;
3674 0 0       0 close($fh) or die "Can't close file: $_: $!";
3675             }
3676              
3677             # filename is not .COM .EXE .BAT .CMD
3678 0         0 return '';
3679             }
3680             }
3681 0         0 return undef;
3682             }
3683              
3684             #
3685             # Big5-HKSCS file test -o $_
3686             #
3687             sub Ebig5hkscs::o_() {
3688              
3689 0 0   0 0 0 if (-e $_) {
    0          
3690 0 0       0 return -o _ ? 1 : '';
3691             }
3692             elsif (_MSWin32_5Cended_path($_)) {
3693 0 0       0 if (-d "$_/.") {
3694 0 0       0 return -o _ ? 1 : '';
3695             }
3696             else {
3697 0         0 my $fh = gensym();
3698 0 0       0 if (_open_r($fh, $_)) {
3699 0         0 my $o = -o $fh;
3700 0 0       0 close($fh) or die "Can't close file: $_: $!";
3701 0 0       0 return $o ? 1 : '';
3702             }
3703             }
3704             }
3705 0         0 return undef;
3706             }
3707              
3708             #
3709             # Big5-HKSCS file test -R $_
3710             #
3711             sub Ebig5hkscs::R_() {
3712              
3713 0 0   0 0 0 if (-e $_) {
    0          
3714 0 0       0 return -R _ ? 1 : '';
3715             }
3716             elsif (_MSWin32_5Cended_path($_)) {
3717 0 0       0 if (-d "$_/.") {
3718 0 0       0 return -R _ ? 1 : '';
3719             }
3720             else {
3721 0         0 my $fh = gensym();
3722 0 0       0 if (_open_r($fh, $_)) {
3723 0         0 my $R = -R $fh;
3724 0 0       0 close($fh) or die "Can't close file: $_: $!";
3725 0 0       0 return $R ? 1 : '';
3726             }
3727             }
3728             }
3729 0         0 return undef;
3730             }
3731              
3732             #
3733             # Big5-HKSCS file test -W $_
3734             #
3735             sub Ebig5hkscs::W_() {
3736              
3737 0 0   0 0 0 if (-e $_) {
    0          
3738 0 0       0 return -W _ ? 1 : '';
3739             }
3740             elsif (_MSWin32_5Cended_path($_)) {
3741 0 0       0 if (-d "$_/.") {
3742 0 0       0 return -W _ ? 1 : '';
3743             }
3744             else {
3745 0         0 my $fh = gensym();
3746 0 0       0 if (_open_a($fh, $_)) {
3747 0         0 my $W = -W $fh;
3748 0 0       0 close($fh) or die "Can't close file: $_: $!";
3749 0 0       0 return $W ? 1 : '';
3750             }
3751             }
3752             }
3753 0         0 return undef;
3754             }
3755              
3756             #
3757             # Big5-HKSCS file test -X $_
3758             #
3759             sub Ebig5hkscs::X_() {
3760              
3761 0 0   0 0 0 if (-e $_) {
    0          
3762 0 0       0 return -X _ ? 1 : '';
3763             }
3764             elsif (_MSWin32_5Cended_path($_)) {
3765 0 0       0 if (-d "$_/.") {
3766 0 0       0 return -X _ ? 1 : '';
3767             }
3768             else {
3769 0         0 my $fh = gensym();
3770 0 0       0 if (_open_r($fh, $_)) {
3771 0         0 my $dummy_for_underline_cache = -X $fh;
3772 0 0       0 close($fh) or die "Can't close file: $_: $!";
3773             }
3774              
3775             # filename is not .COM .EXE .BAT .CMD
3776 0         0 return '';
3777             }
3778             }
3779 0         0 return undef;
3780             }
3781              
3782             #
3783             # Big5-HKSCS file test -O $_
3784             #
3785             sub Ebig5hkscs::O_() {
3786              
3787 0 0   0 0 0 if (-e $_) {
    0          
3788 0 0       0 return -O _ ? 1 : '';
3789             }
3790             elsif (_MSWin32_5Cended_path($_)) {
3791 0 0       0 if (-d "$_/.") {
3792 0 0       0 return -O _ ? 1 : '';
3793             }
3794             else {
3795 0         0 my $fh = gensym();
3796 0 0       0 if (_open_r($fh, $_)) {
3797 0         0 my $O = -O $fh;
3798 0 0       0 close($fh) or die "Can't close file: $_: $!";
3799 0 0       0 return $O ? 1 : '';
3800             }
3801             }
3802             }
3803 0         0 return undef;
3804             }
3805              
3806             #
3807             # Big5-HKSCS file test -e $_
3808             #
3809             sub Ebig5hkscs::e_() {
3810              
3811 0 0   0 0 0 if (-e $_) {
    0          
3812 0         0 return 1;
3813             }
3814             elsif (_MSWin32_5Cended_path($_)) {
3815 0 0       0 if (-d "$_/.") {
3816 0         0 return 1;
3817             }
3818             else {
3819 0         0 my $fh = gensym();
3820 0 0       0 if (_open_r($fh, $_)) {
3821 0         0 my $e = -e $fh;
3822 0 0       0 close($fh) or die "Can't close file: $_: $!";
3823 0 0       0 return $e ? 1 : '';
3824             }
3825             }
3826             }
3827 0         0 return undef;
3828             }
3829              
3830             #
3831             # Big5-HKSCS file test -z $_
3832             #
3833             sub Ebig5hkscs::z_() {
3834              
3835 0 0   0 0 0 if (-e $_) {
    0          
3836 0 0       0 return -z _ ? 1 : '';
3837             }
3838             elsif (_MSWin32_5Cended_path($_)) {
3839 0 0       0 if (-d "$_/.") {
3840 0 0       0 return -z _ ? 1 : '';
3841             }
3842             else {
3843 0         0 my $fh = gensym();
3844 0 0       0 if (_open_r($fh, $_)) {
3845 0         0 my $z = -z $fh;
3846 0 0       0 close($fh) or die "Can't close file: $_: $!";
3847 0 0       0 return $z ? 1 : '';
3848             }
3849             }
3850             }
3851 0         0 return undef;
3852             }
3853              
3854             #
3855             # Big5-HKSCS file test -s $_
3856             #
3857             sub Ebig5hkscs::s_() {
3858              
3859 0 0   0 0 0 if (-e $_) {
    0          
3860 0         0 return -s _;
3861             }
3862             elsif (_MSWin32_5Cended_path($_)) {
3863 0 0       0 if (-d "$_/.") {
3864 0         0 return -s _;
3865             }
3866             else {
3867 0         0 my $fh = gensym();
3868 0 0       0 if (_open_r($fh, $_)) {
3869 0         0 my $s = -s $fh;
3870 0 0       0 close($fh) or die "Can't close file: $_: $!";
3871 0         0 return $s;
3872             }
3873             }
3874             }
3875 0         0 return undef;
3876             }
3877              
3878             #
3879             # Big5-HKSCS file test -f $_
3880             #
3881             sub Ebig5hkscs::f_() {
3882              
3883 0 0   0 0 0 if (-e $_) {
    0          
3884 0 0       0 return -f _ ? 1 : '';
3885             }
3886             elsif (_MSWin32_5Cended_path($_)) {
3887 0 0       0 if (-d "$_/.") {
3888 0         0 return '';
3889             }
3890             else {
3891 0         0 my $fh = gensym();
3892 0 0       0 if (_open_r($fh, $_)) {
3893 0         0 my $f = -f $fh;
3894 0 0       0 close($fh) or die "Can't close file: $_: $!";
3895 0 0       0 return $f ? 1 : '';
3896             }
3897             }
3898             }
3899 0         0 return undef;
3900             }
3901              
3902             #
3903             # Big5-HKSCS file test -d $_
3904             #
3905             sub Ebig5hkscs::d_() {
3906              
3907 0 0   0 0 0 if (-e $_) {
    0          
3908 0 0       0 return -d _ ? 1 : '';
3909             }
3910             elsif (_MSWin32_5Cended_path($_)) {
3911 0 0       0 return -d "$_/." ? 1 : '';
3912             }
3913 0         0 return undef;
3914             }
3915              
3916             #
3917             # Big5-HKSCS file test -l $_
3918             #
3919             sub Ebig5hkscs::l_() {
3920              
3921 0 0   0 0 0 if (-e $_) {
    0          
3922 0 0       0 return -l _ ? 1 : '';
3923             }
3924             elsif (_MSWin32_5Cended_path($_)) {
3925 0 0       0 if (-d "$_/.") {
3926 0 0       0 return -l _ ? 1 : '';
3927             }
3928             else {
3929 0         0 my $fh = gensym();
3930 0 0       0 if (_open_r($fh, $_)) {
3931 0         0 my $l = -l $fh;
3932 0 0       0 close($fh) or die "Can't close file: $_: $!";
3933 0 0       0 return $l ? 1 : '';
3934             }
3935             }
3936             }
3937 0         0 return undef;
3938             }
3939              
3940             #
3941             # Big5-HKSCS file test -p $_
3942             #
3943             sub Ebig5hkscs::p_() {
3944              
3945 0 0   0 0 0 if (-e $_) {
    0          
3946 0 0       0 return -p _ ? 1 : '';
3947             }
3948             elsif (_MSWin32_5Cended_path($_)) {
3949 0 0       0 if (-d "$_/.") {
3950 0 0       0 return -p _ ? 1 : '';
3951             }
3952             else {
3953 0         0 my $fh = gensym();
3954 0 0       0 if (_open_r($fh, $_)) {
3955 0         0 my $p = -p $fh;
3956 0 0       0 close($fh) or die "Can't close file: $_: $!";
3957 0 0       0 return $p ? 1 : '';
3958             }
3959             }
3960             }
3961 0         0 return undef;
3962             }
3963              
3964             #
3965             # Big5-HKSCS file test -S $_
3966             #
3967             sub Ebig5hkscs::S_() {
3968              
3969 0 0   0 0 0 if (-e $_) {
    0          
3970 0 0       0 return -S _ ? 1 : '';
3971             }
3972             elsif (_MSWin32_5Cended_path($_)) {
3973 0 0       0 if (-d "$_/.") {
3974 0 0       0 return -S _ ? 1 : '';
3975             }
3976             else {
3977 0         0 my $fh = gensym();
3978 0 0       0 if (_open_r($fh, $_)) {
3979 0         0 my $S = -S $fh;
3980 0 0       0 close($fh) or die "Can't close file: $_: $!";
3981 0 0       0 return $S ? 1 : '';
3982             }
3983             }
3984             }
3985 0         0 return undef;
3986             }
3987              
3988             #
3989             # Big5-HKSCS file test -b $_
3990             #
3991             sub Ebig5hkscs::b_() {
3992              
3993 0 0   0 0 0 if (-e $_) {
    0          
3994 0 0       0 return -b _ ? 1 : '';
3995             }
3996             elsif (_MSWin32_5Cended_path($_)) {
3997 0 0       0 if (-d "$_/.") {
3998 0 0       0 return -b _ ? 1 : '';
3999             }
4000             else {
4001 0         0 my $fh = gensym();
4002 0 0       0 if (_open_r($fh, $_)) {
4003 0         0 my $b = -b $fh;
4004 0 0       0 close($fh) or die "Can't close file: $_: $!";
4005 0 0       0 return $b ? 1 : '';
4006             }
4007             }
4008             }
4009 0         0 return undef;
4010             }
4011              
4012             #
4013             # Big5-HKSCS file test -c $_
4014             #
4015             sub Ebig5hkscs::c_() {
4016              
4017 0 0   0 0 0 if (-e $_) {
    0          
4018 0 0       0 return -c _ ? 1 : '';
4019             }
4020             elsif (_MSWin32_5Cended_path($_)) {
4021 0 0       0 if (-d "$_/.") {
4022 0 0       0 return -c _ ? 1 : '';
4023             }
4024             else {
4025 0         0 my $fh = gensym();
4026 0 0       0 if (_open_r($fh, $_)) {
4027 0         0 my $c = -c $fh;
4028 0 0       0 close($fh) or die "Can't close file: $_: $!";
4029 0 0       0 return $c ? 1 : '';
4030             }
4031             }
4032             }
4033 0         0 return undef;
4034             }
4035              
4036             #
4037             # Big5-HKSCS file test -u $_
4038             #
4039             sub Ebig5hkscs::u_() {
4040              
4041 0 0   0 0 0 if (-e $_) {
    0          
4042 0 0       0 return -u _ ? 1 : '';
4043             }
4044             elsif (_MSWin32_5Cended_path($_)) {
4045 0 0       0 if (-d "$_/.") {
4046 0 0       0 return -u _ ? 1 : '';
4047             }
4048             else {
4049 0         0 my $fh = gensym();
4050 0 0       0 if (_open_r($fh, $_)) {
4051 0         0 my $u = -u $fh;
4052 0 0       0 close($fh) or die "Can't close file: $_: $!";
4053 0 0       0 return $u ? 1 : '';
4054             }
4055             }
4056             }
4057 0         0 return undef;
4058             }
4059              
4060             #
4061             # Big5-HKSCS file test -g $_
4062             #
4063             sub Ebig5hkscs::g_() {
4064              
4065 0 0   0 0 0 if (-e $_) {
    0          
4066 0 0       0 return -g _ ? 1 : '';
4067             }
4068             elsif (_MSWin32_5Cended_path($_)) {
4069 0 0       0 if (-d "$_/.") {
4070 0 0       0 return -g _ ? 1 : '';
4071             }
4072             else {
4073 0         0 my $fh = gensym();
4074 0 0       0 if (_open_r($fh, $_)) {
4075 0         0 my $g = -g $fh;
4076 0 0       0 close($fh) or die "Can't close file: $_: $!";
4077 0 0       0 return $g ? 1 : '';
4078             }
4079             }
4080             }
4081 0         0 return undef;
4082             }
4083              
4084             #
4085             # Big5-HKSCS file test -k $_
4086             #
4087             sub Ebig5hkscs::k_() {
4088              
4089 0 0   0 0 0 if ($] =~ /^5\.008/oxms) {
4090 0 0       0 return wantarray ? ('',@_) : '';
4091             }
4092 0 0       0 return wantarray ? ($_,@_) : $_;
4093             }
4094              
4095             #
4096             # Big5-HKSCS file test -T $_
4097             #
4098             sub Ebig5hkscs::T_() {
4099              
4100 0     0 0 0 my $T = 1;
4101              
4102 0 0 0     0 if (-d $_ or -d "$_/.") {
4103 0         0 return undef;
4104             }
4105 0         0 my $fh = gensym();
4106 0 0       0 if (_open_r($fh, $_)) {
4107             }
4108             else {
4109 0         0 return undef;
4110             }
4111              
4112 0 0       0 if (sysread $fh, my $block, 512) {
4113 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4114 0         0 $T = '';
4115             }
4116             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4117 0         0 $T = '';
4118             }
4119             }
4120              
4121             # 0 byte or eof
4122             else {
4123 0         0 $T = 1;
4124             }
4125 0         0 my $dummy_for_underline_cache = -T $fh;
4126 0 0       0 close($fh) or die "Can't close file: $_: $!";
4127              
4128 0         0 return $T;
4129             }
4130              
4131             #
4132             # Big5-HKSCS file test -B $_
4133             #
4134             sub Ebig5hkscs::B_() {
4135              
4136 0     0 0 0 my $B = '';
4137              
4138 0 0 0     0 if (-d $_ or -d "$_/.") {
4139 0         0 return undef;
4140             }
4141 0         0 my $fh = gensym();
4142 0 0       0 if (_open_r($fh, $_)) {
4143             }
4144             else {
4145 0         0 return undef;
4146             }
4147              
4148 0 0       0 if (sysread $fh, my $block, 512) {
4149 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4150 0         0 $B = 1;
4151             }
4152             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4153 0         0 $B = 1;
4154             }
4155             }
4156              
4157             # 0 byte or eof
4158             else {
4159 0         0 $B = 1;
4160             }
4161 0         0 my $dummy_for_underline_cache = -B $fh;
4162 0 0       0 close($fh) or die "Can't close file: $_: $!";
4163              
4164 0         0 return $B;
4165             }
4166              
4167             #
4168             # Big5-HKSCS file test -M $_
4169             #
4170             sub Ebig5hkscs::M_() {
4171              
4172 0 0   0 0 0 if (-e $_) {
    0          
4173 0         0 return -M _;
4174             }
4175             elsif (_MSWin32_5Cended_path($_)) {
4176 0 0       0 if (-d "$_/.") {
4177 0         0 return -M _;
4178             }
4179             else {
4180 0         0 my $fh = gensym();
4181 0 0       0 if (_open_r($fh, $_)) {
4182 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4183 0 0       0 close($fh) or die "Can't close file: $_: $!";
4184 0         0 my $M = ($^T - $mtime) / (24*60*60);
4185 0         0 return $M;
4186             }
4187             }
4188             }
4189 0         0 return undef;
4190             }
4191              
4192             #
4193             # Big5-HKSCS file test -A $_
4194             #
4195             sub Ebig5hkscs::A_() {
4196              
4197 0 0   0 0 0 if (-e $_) {
    0          
4198 0         0 return -A _;
4199             }
4200             elsif (_MSWin32_5Cended_path($_)) {
4201 0 0       0 if (-d "$_/.") {
4202 0         0 return -A _;
4203             }
4204             else {
4205 0         0 my $fh = gensym();
4206 0 0       0 if (_open_r($fh, $_)) {
4207 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4208 0 0       0 close($fh) or die "Can't close file: $_: $!";
4209 0         0 my $A = ($^T - $atime) / (24*60*60);
4210 0         0 return $A;
4211             }
4212             }
4213             }
4214 0         0 return undef;
4215             }
4216              
4217             #
4218             # Big5-HKSCS file test -C $_
4219             #
4220             sub Ebig5hkscs::C_() {
4221              
4222 0 0   0 0 0 if (-e $_) {
    0          
4223 0         0 return -C _;
4224             }
4225             elsif (_MSWin32_5Cended_path($_)) {
4226 0 0       0 if (-d "$_/.") {
4227 0         0 return -C _;
4228             }
4229             else {
4230 0         0 my $fh = gensym();
4231 0 0       0 if (_open_r($fh, $_)) {
4232 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4233 0 0       0 close($fh) or die "Can't close file: $_: $!";
4234 0         0 my $C = ($^T - $ctime) / (24*60*60);
4235 0         0 return $C;
4236             }
4237             }
4238             }
4239 0         0 return undef;
4240             }
4241              
4242             #
4243             # Big5-HKSCS path globbing (with parameter)
4244             #
4245             sub Ebig5hkscs::glob($) {
4246              
4247 0 0   0 0 0 if (wantarray) {
4248 0         0 my @glob = _DOS_like_glob(@_);
4249 0         0 for my $glob (@glob) {
4250 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4251             }
4252 0         0 return @glob;
4253             }
4254             else {
4255 0         0 my $glob = _DOS_like_glob(@_);
4256 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4257 0         0 return $glob;
4258             }
4259             }
4260              
4261             #
4262             # Big5-HKSCS path globbing (without parameter)
4263             #
4264             sub Ebig5hkscs::glob_() {
4265              
4266 0 0   0 0 0 if (wantarray) {
4267 0         0 my @glob = _DOS_like_glob();
4268 0         0 for my $glob (@glob) {
4269 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4270             }
4271 0         0 return @glob;
4272             }
4273             else {
4274 0         0 my $glob = _DOS_like_glob();
4275 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4276 0         0 return $glob;
4277             }
4278             }
4279              
4280             #
4281             # Big5-HKSCS path globbing via File::DosGlob 1.10
4282             #
4283             # Often I confuse "_dosglob" and "_doglob".
4284             # So, I renamed "_dosglob" to "_DOS_like_glob".
4285             #
4286             my %iter;
4287             my %entries;
4288             sub _DOS_like_glob {
4289              
4290             # context (keyed by second cxix argument provided by core)
4291 0     0   0 my($expr,$cxix) = @_;
4292              
4293             # glob without args defaults to $_
4294 0 0       0 $expr = $_ if not defined $expr;
4295              
4296             # represents the current user's home directory
4297             #
4298             # 7.3. Expanding Tildes in Filenames
4299             # in Chapter 7. File Access
4300             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4301             #
4302             # and File::HomeDir, File::HomeDir::Windows module
4303              
4304             # DOS-like system
4305 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4306 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
4307             { my_home_MSWin32() }oxmse;
4308             }
4309              
4310             # UNIX-like system
4311 0 0 0     0 else {
  0         0  
4312             $expr =~ s{ \A ~ ( (?:[^\x81-\xFE/]|[\x81-\xFE][\x00-\xFF])* ) }
4313             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
4314             }
4315 0 0       0  
4316 0 0       0 # assume global context if not provided one
4317             $cxix = '_G_' if not defined $cxix;
4318             $iter{$cxix} = 0 if not exists $iter{$cxix};
4319 0 0       0  
4320 0         0 # if we're just beginning, do it all first
4321             if ($iter{$cxix} == 0) {
4322             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
4323             }
4324 0 0       0  
4325 0         0 # chuck it all out, quick or slow
4326 0         0 if (wantarray) {
  0         0  
4327             delete $iter{$cxix};
4328             return @{delete $entries{$cxix}};
4329 0 0       0 }
  0         0  
4330 0         0 else {
  0         0  
4331             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
4332             return shift @{$entries{$cxix}};
4333             }
4334 0         0 else {
4335 0         0 # return undef for EOL
4336 0         0 delete $iter{$cxix};
4337             delete $entries{$cxix};
4338             return undef;
4339             }
4340             }
4341             }
4342              
4343             #
4344             # Big5-HKSCS path globbing subroutine
4345             #
4346 0     0   0 sub _do_glob {
4347 0         0  
4348 0         0 my($cond,@expr) = @_;
4349             my @glob = ();
4350             my $fix_drive_relative_paths = 0;
4351 0         0  
4352 0 0       0 OUTER:
4353 0 0       0 for my $expr (@expr) {
4354             next OUTER if not defined $expr;
4355 0         0 next OUTER if $expr eq '';
4356 0         0  
4357 0         0 my @matched = ();
4358 0         0 my @globdir = ();
4359 0         0 my $head = '.';
4360             my $pathsep = '/';
4361             my $tail;
4362 0 0       0  
4363 0         0 # if argument is within quotes strip em and do no globbing
4364 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
4365 0 0       0 $expr = $1;
4366 0         0 if ($cond eq 'd') {
4367             if (Ebig5hkscs::d $expr) {
4368             push @glob, $expr;
4369             }
4370 0 0       0 }
4371 0         0 else {
4372             if (Ebig5hkscs::e $expr) {
4373             push @glob, $expr;
4374 0         0 }
4375             }
4376             next OUTER;
4377             }
4378              
4379 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
4380 0 0       0 # to h:./*.pm to expand correctly
4381 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4382             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^\x81-\xFE/\\]|[\x81-\xFE][\x00-\xFF]) #$1./$2#oxms) {
4383             $fix_drive_relative_paths = 1;
4384             }
4385 0 0       0 }
4386 0 0       0  
4387 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
4388 0         0 if ($tail eq '') {
4389             push @glob, $expr;
4390 0 0       0 next OUTER;
4391 0 0       0 }
4392 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
4393 0         0 if (@globdir = _do_glob('d', $head)) {
4394             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
4395             next OUTER;
4396 0 0 0     0 }
4397 0         0 }
4398             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
4399 0         0 $head .= $pathsep;
4400             }
4401             $expr = $tail;
4402             }
4403 0 0       0  
4404 0 0       0 # If file component has no wildcards, we can avoid opendir
4405 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
4406             if ($head eq '.') {
4407 0 0 0     0 $head = '';
4408 0         0 }
4409             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4410 0         0 $head .= $pathsep;
4411 0 0       0 }
4412 0 0       0 $head .= $expr;
4413 0         0 if ($cond eq 'd') {
4414             if (Ebig5hkscs::d $head) {
4415             push @glob, $head;
4416             }
4417 0 0       0 }
4418 0         0 else {
4419             if (Ebig5hkscs::e $head) {
4420             push @glob, $head;
4421 0         0 }
4422             }
4423 0 0       0 next OUTER;
4424 0         0 }
4425 0         0 Ebig5hkscs::opendir(*DIR, $head) or next OUTER;
4426             my @leaf = readdir DIR;
4427 0 0       0 closedir DIR;
4428 0         0  
4429             if ($head eq '.') {
4430 0 0 0     0 $head = '';
4431 0         0 }
4432             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4433             $head .= $pathsep;
4434 0         0 }
4435 0         0  
4436 0         0 my $pattern = '';
4437             while ($expr =~ / \G ($q_char) /oxgc) {
4438             my $char = $1;
4439              
4440             # 6.9. Matching Shell Globs as Regular Expressions
4441             # in Chapter 6. Pattern Matching
4442             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4443 0 0       0 # (and so on)
    0          
    0          
4444 0         0  
4445             if ($char eq '*') {
4446             $pattern .= "(?:$your_char)*",
4447 0         0 }
4448             elsif ($char eq '?') {
4449             $pattern .= "(?:$your_char)?", # DOS style
4450             # $pattern .= "(?:$your_char)", # UNIX style
4451 0         0 }
4452             elsif ((my $fc = Ebig5hkscs::fc($char)) ne $char) {
4453             $pattern .= $fc;
4454 0         0 }
4455             else {
4456             $pattern .= quotemeta $char;
4457 0     0   0 }
  0         0  
4458             }
4459             my $matchsub = sub { Ebig5hkscs::fc($_[0]) =~ /\A $pattern \z/xms };
4460              
4461             # if ($@) {
4462             # print STDERR "$0: $@\n";
4463             # next OUTER;
4464             # }
4465 0         0  
4466 0 0 0     0 INNER:
4467 0         0 for my $leaf (@leaf) {
4468             if ($leaf eq '.' or $leaf eq '..') {
4469 0 0 0     0 next INNER;
4470 0         0 }
4471             if ($cond eq 'd' and not Ebig5hkscs::d "$head$leaf") {
4472             next INNER;
4473 0 0       0 }
4474 0         0  
4475 0         0 if (&$matchsub($leaf)) {
4476             push @matched, "$head$leaf";
4477             next INNER;
4478             }
4479              
4480             # [DOS compatibility special case]
4481 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
4482              
4483             if (Ebig5hkscs::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
4484             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
4485 0 0       0 Ebig5hkscs::index($pattern,'\\.') != -1 # pattern has a dot.
4486 0         0 ) {
4487 0         0 if (&$matchsub("$leaf.")) {
4488             push @matched, "$head$leaf";
4489             next INNER;
4490             }
4491 0 0       0 }
4492 0         0 }
4493             if (@matched) {
4494             push @glob, @matched;
4495 0 0       0 }
4496 0         0 }
4497 0         0 if ($fix_drive_relative_paths) {
4498             for my $glob (@glob) {
4499             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
4500 0         0 }
4501             }
4502             return @glob;
4503             }
4504              
4505             #
4506             # Big5-HKSCS parse line
4507             #
4508 0     0   0 sub _parse_line {
4509              
4510 0         0 my($line) = @_;
4511 0         0  
4512 0         0 $line .= ' ';
4513             my @piece = ();
4514             while ($line =~ /
4515             " ( (?>(?: [^\x81-\xFE"] |[\x81-\xFE][\x00-\xFF] )* ) ) " (?>\s+) |
4516             ( (?>(?: [^\x81-\xFE"\s]|[\x81-\xFE][\x00-\xFF] )* ) ) (?>\s+)
4517 0 0       0 /oxmsg
4518             ) {
4519 0         0 push @piece, defined($1) ? $1 : $2;
4520             }
4521             return @piece;
4522             }
4523              
4524             #
4525             # Big5-HKSCS parse path
4526             #
4527 0     0   0 sub _parse_path {
4528              
4529 0         0 my($path,$pathsep) = @_;
4530 0         0  
4531 0         0 $path .= '/';
4532             my @subpath = ();
4533             while ($path =~ /
4534             ((?: [^\x81-\xFE\/\\]|[\x81-\xFE][\x00-\xFF] )+?) [\/\\]
4535 0         0 /oxmsg
4536             ) {
4537             push @subpath, $1;
4538 0         0 }
4539 0         0  
4540 0         0 my $tail = pop @subpath;
4541             my $head = join $pathsep, @subpath;
4542             return $head, $tail;
4543             }
4544              
4545             #
4546             # via File::HomeDir::Windows 1.00
4547             #
4548             sub my_home_MSWin32 {
4549              
4550             # A lot of unix people and unix-derived tools rely on
4551 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
4552 0         0 # so that they can replace raw HOME calls with File::HomeDir.
4553             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
4554             return $ENV{'HOME'};
4555             }
4556              
4557 0         0 # Do we have a user profile?
4558             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
4559             return $ENV{'USERPROFILE'};
4560             }
4561              
4562 0         0 # Some Windows use something like $ENV{'HOME'}
4563             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
4564             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
4565 0         0 }
4566              
4567             return undef;
4568             }
4569              
4570             #
4571             # via File::HomeDir::Unix 1.00
4572 0     0 0 0 #
4573             sub my_home {
4574 0 0 0     0 my $home;
    0 0        
4575 0         0  
4576             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
4577             $home = $ENV{'HOME'};
4578             }
4579              
4580             # This is from the original code, but I'm guessing
4581 0         0 # it means "login directory" and exists on some Unixes.
4582             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
4583             $home = $ENV{'LOGDIR'};
4584             }
4585              
4586             ### More-desperate methods
4587              
4588 0         0 # Light desperation on any (Unixish) platform
4589             else {
4590             $home = CORE::eval q{ (getpwuid($<))[7] };
4591             }
4592              
4593 0 0 0     0 # On Unix in general, a non-existant home means "no home"
4594 0         0 # For example, "nobody"-like users might use /nonexistant
4595             if (defined $home and ! Ebig5hkscs::d($home)) {
4596 0         0 $home = undef;
4597             }
4598             return $home;
4599             }
4600              
4601             #
4602             # Big5-HKSCS file lstat (with parameter)
4603             #
4604 0 0   0 0 0 sub Ebig5hkscs::lstat(*) {
4605              
4606 0 0       0 local $_ = shift if @_;
    0          
4607 0         0  
4608             if (-e $_) {
4609             return CORE::lstat _;
4610             }
4611             elsif (_MSWin32_5Cended_path($_)) {
4612              
4613             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Ebig5hkscs::lstat()
4614             # on Windows opens the file for the path which has 5c at end.
4615 0         0 # (and so on)
4616 0 0       0  
4617 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4618 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4619 0 0       0 if (wantarray) {
4620 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4621             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4622             return @stat;
4623 0         0 }
4624 0 0       0 else {
4625 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4626             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4627             return $stat;
4628             }
4629 0 0       0 }
4630             }
4631             return wantarray ? () : undef;
4632             }
4633              
4634             #
4635             # Big5-HKSCS file lstat (without parameter)
4636             #
4637 0 0   0 0 0 sub Ebig5hkscs::lstat_() {
    0          
4638 0         0  
4639             if (-e $_) {
4640             return CORE::lstat _;
4641 0         0 }
4642 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4643 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4644 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4645 0 0       0 if (wantarray) {
4646 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4647             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4648             return @stat;
4649 0         0 }
4650 0 0       0 else {
4651 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4652             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4653             return $stat;
4654             }
4655 0 0       0 }
4656             }
4657             return wantarray ? () : undef;
4658             }
4659              
4660             #
4661             # Big5-HKSCS path opendir
4662             #
4663 0     0 0 0 sub Ebig5hkscs::opendir(*$) {
4664 0 0       0  
    0          
4665 0         0 my $dh = qualify_to_ref $_[0];
4666             if (CORE::opendir $dh, $_[1]) {
4667             return 1;
4668 0 0       0 }
4669 0         0 elsif (_MSWin32_5Cended_path($_[1])) {
4670             if (CORE::opendir $dh, "$_[1]/.") {
4671             return 1;
4672 0         0 }
4673             }
4674             return undef;
4675             }
4676              
4677             #
4678             # Big5-HKSCS file stat (with parameter)
4679             #
4680 0 50   384 0 0 sub Ebig5hkscs::stat(*) {
4681              
4682 384         2381 local $_ = shift if @_;
4683 384 50       2908  
    50          
    0          
4684 384         13947 my $fh = qualify_to_ref $_;
4685             if (defined fileno $fh) {
4686             return CORE::stat $fh;
4687 0         0 }
4688             elsif (-e $_) {
4689             return CORE::stat _;
4690             }
4691             elsif (_MSWin32_5Cended_path($_)) {
4692              
4693             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Ebig5hkscs::stat()
4694             # on Windows opens the file for the path which has 5c at end.
4695 384         3065 # (and so on)
4696 0 0       0  
4697 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4698 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4699 0 0       0 if (wantarray) {
4700 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4701             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4702             return @stat;
4703 0         0 }
4704 0 0       0 else {
4705 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4706             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4707             return $stat;
4708             }
4709 0 0       0 }
4710             }
4711             return wantarray ? () : undef;
4712             }
4713              
4714             #
4715             # Big5-HKSCS file stat (without parameter)
4716             #
4717 0     0 0 0 sub Ebig5hkscs::stat_() {
4718 0 0       0  
    0          
    0          
4719 0         0 my $fh = qualify_to_ref $_;
4720             if (defined fileno $fh) {
4721             return CORE::stat $fh;
4722 0         0 }
4723             elsif (-e $_) {
4724             return CORE::stat _;
4725 0         0 }
4726 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4727 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4728 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4729 0 0       0 if (wantarray) {
4730 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4731             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4732             return @stat;
4733 0         0 }
4734 0 0       0 else {
4735 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4736             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4737             return $stat;
4738             }
4739 0 0       0 }
4740             }
4741             return wantarray ? () : undef;
4742             }
4743              
4744             #
4745             # Big5-HKSCS path unlink
4746             #
4747 0 0   0 0 0 sub Ebig5hkscs::unlink(@) {
4748              
4749 0         0 local @_ = ($_) unless @_;
4750 0         0  
4751 0 0       0 my $unlink = 0;
    0          
    0          
4752 0         0 for (@_) {
4753             if (CORE::unlink) {
4754             $unlink++;
4755             }
4756             elsif (Ebig5hkscs::d($_)) {
4757 0         0 }
4758 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
  0         0  
4759 0 0       0 my @char = /\G (?>$q_char) /oxmsg;
4760 0         0 my $file = join '', map {{'/' => '\\'}->{$_} || $_} @char;
4761             if ($file =~ / \A (?:$q_char)*? [ ] /oxms) {
4762 0         0 $file = qq{"$file"};
4763 0 0       0 }
4764 0 0       0 my $fh = gensym();
4765             if (_open_r($fh, $_)) {
4766             close($fh) or die "Can't close file: $_: $!";
4767 0 0 0     0  
    0          
4768 0         0 # cmd.exe on Windows NT, Windows 2000, Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
4769             if ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
4770             CORE::system 'DEL', '/F', $file, '2>NUL';
4771             }
4772              
4773 0         0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
4774             elsif (qx{ver} =~ /\b(?:Windows 2000)\b/oms) {
4775             CORE::system 'DEL', '/F', $file, '2>NUL';
4776             }
4777              
4778             # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
4779 0         0 # command.com can not "2>NUL"
4780 0         0 else {
4781             CORE::system 'ATTRIB', '-R', $file; # clears Read-only file attribute
4782             CORE::system 'DEL', $file;
4783 0 0       0 }
4784 0 0       0  
4785             if (_open_r($fh, $_)) {
4786             close($fh) or die "Can't close file: $_: $!";
4787 0         0 }
4788             else {
4789             $unlink++;
4790             }
4791             }
4792 0         0 }
4793             }
4794             return $unlink;
4795             }
4796              
4797             #
4798             # Big5-HKSCS chdir
4799             #
4800 0 0   0 0 0 sub Ebig5hkscs::chdir(;$) {
4801 0         0  
4802             if (@_ == 0) {
4803             return CORE::chdir;
4804 0         0 }
4805              
4806 0 0       0 my($dir) = @_;
4807 0 0       0  
4808 0         0 if (_MSWin32_5Cended_path($dir)) {
4809             if (not Ebig5hkscs::d $dir) {
4810             return 0;
4811 0 0 0     0 }
    0          
4812 0         0  
4813             if ($] =~ /^5\.005/oxms) {
4814             return CORE::chdir $dir;
4815 0         0 }
4816 0         0 elsif (($] =~ /^(?:5\.006|5\.008000)/oxms) and ($^O eq 'MSWin32')) {
4817             local $@;
4818             my $chdir = CORE::eval q{
4819             CORE::require 'jacode.pl';
4820              
4821             # P.676 ${^WIDE_SYSTEM_CALLS}
4822             # in Chapter 28: Special Names
4823             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4824              
4825             # P.790 ${^WIDE_SYSTEM_CALLS}
4826             # in Chapter 25: Special Names
4827             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4828              
4829             local ${^WIDE_SYSTEM_CALLS} = 1;
4830 0 0       0 return CORE::chdir jcode::utf8($dir,'sjis');
4831 0         0 };
4832             if (not $@) {
4833             return $chdir;
4834             }
4835             }
4836              
4837             # old idea (Win32 module required)
4838             elsif (0) {
4839             local $@;
4840             my $shortdir = '';
4841             my $chdir = CORE::eval q{
4842             use Win32;
4843             $shortdir = Win32::GetShortPathName($dir);
4844             if ($shortdir ne $dir) {
4845             return CORE::chdir $shortdir;
4846             }
4847             else {
4848             return 0;
4849             }
4850             };
4851             if ($@) {
4852             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4853             while ($char[-1] eq "\x5C") {
4854             pop @char;
4855             }
4856             $dir = join '', @char;
4857             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path), Win32.pm module may help you";
4858             }
4859             elsif ($shortdir eq $dir) {
4860             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4861             while ($char[-1] eq "\x5C") {
4862             pop @char;
4863             }
4864             $dir = join '', @char;
4865             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path)";
4866             }
4867             return $chdir;
4868             }
4869 0         0  
4870             # rejected idea ...
4871             elsif (0) {
4872              
4873             # MSDN SetCurrentDirectory function
4874             # http://msdn.microsoft.com/ja-jp/library/windows/desktop/aa365530(v=vs.85).aspx
4875             #
4876             # Data Execution Prevention (DEP)
4877             # http://vlaurie.com/computers2/Articles/dep.htm
4878             #
4879             # Learning x86 assembler with Perl -- Shibuya.pm#11
4880             # http://developer.cybozu.co.jp/takesako/2009/06/perl-x86-shibuy.html
4881             #
4882             # Introduction to Win32::API programming in Perl
4883             # http://d.hatena.ne.jp/TAKESAKO/20090324/1237879559
4884             #
4885             # DynaLoader - Dynamically load C libraries into Perl code
4886             # http://perldoc.perl.org/DynaLoader.html
4887             #
4888             # Basic knowledge of DynaLoader
4889             # http://blog.64p.org/entry/20090313/1236934042
4890              
4891             if (($] =~ /^5\.006/oxms) and
4892             ($^O eq 'MSWin32') and
4893             ($ENV{'PROCESSOR_ARCHITECTURE'} eq 'x86') and
4894             CORE::eval(q{CORE::require 'Dyna'.'Loader'})
4895             ) {
4896             my $x86 = join('',
4897              
4898             # PUSH Iv
4899             "\x68", pack('P', "$dir\\\0"),
4900              
4901             # MOV eAX, Iv
4902             "\xb8", pack('L',
4903             *{'Dyna'.'Loader::dl_find_symbol'}{'CODE'}->(
4904             *{'Dyna'.'Loader::dl_load_file'}{'CODE'}->("$ENV{'SystemRoot'}\\system32\\kernel32.dll"),
4905             'SetCurrentDirectoryA'
4906             )
4907             ),
4908              
4909             # CALL eAX
4910             "\xff\xd0",
4911              
4912             # RETN
4913             "\xc3",
4914             );
4915             *{'Dyna'.'Loader::dl_install_xsub'}{'CODE'}->('_SetCurrentDirectoryA', unpack('L', pack 'P', $x86));
4916             _SetCurrentDirectoryA();
4917             chomp(my $chdir = qx{chdir});
4918             if (Ebig5hkscs::fc($chdir) eq Ebig5hkscs::fc($dir)) {
4919             return 1;
4920             }
4921             else {
4922             return 0;
4923             }
4924             }
4925             }
4926              
4927             # COMMAND.COM's unhelpful tips:
4928             # Displays a list of files and subdirectories in a directory.
4929             # http://www.lagmonster.org/docs/DOS7/z-dir.html
4930             #
4931             # Syntax:
4932             #
4933             # DIR [drive:] [path] [filename] [/Switches]
4934             #
4935             # /Z Long file names are not displayed in the file listing
4936             #
4937             # Limitations
4938             # The undocumented /Z switch (no long names) would appear to
4939             # have been not fully developed and has a couple of problems:
4940             #
4941             # 1. It will only work if:
4942             # There is no path specified (ie. for the current directory in
4943             # the current drive)
4944             # The path is specified as the root directory of any drive
4945             # (eg. C:\, D:\, etc.)
4946             # The path is specified as the current directory of any drive
4947             # by using the drive letter only (eg. C:, D:, etc.)
4948             # The path is specified as the parent directory using the ..
4949             # notation (eg. DIR .. /Z)
4950             # Any other syntax results in a "File Not Found" error message.
4951             #
4952             # 2. The /Z switch is compatable with the /S switch to show
4953             # subdirectories (as long as the above rules are followed) and
4954             # all the files are shown with short names only. The
4955             # subdirectories are also shown with short names only. However,
4956             # the header for each subdirectory after the first level gives
4957             # the subdirectory's long name.
4958             #
4959             # 3. The /Z switch is also compatable with the /B switch to give
4960             # a simple list of files with short names only. When used with
4961             # the /S switch as well, all files are listed with their full
4962             # paths. The file names themselves are all in short form, and
4963             # the path of those files in the current directory are in short
4964             # form, but the paths of any files in subdirectories are in
4965 0         0 # long filename form.
4966 0         0  
4967 0         0 my $shortdir = '';
4968 0         0 my $i = 0;
4969 0         0 my @subdir = ();
4970 0 0 0     0 while ($dir =~ / \G ($q_char) /oxgc) {
4971 0         0 my $char = $1;
4972 0         0 if (($char eq '\\') or ($char eq '/')) {
4973 0         0 $i++;
4974             $subdir[$i] = $char;
4975             $i++;
4976 0         0 }
4977             else {
4978             $subdir[$i] .= $char;
4979 0 0 0     0 }
4980 0         0 }
4981             if (($subdir[-1] eq '\\') or ($subdir[-1] eq '/')) {
4982             pop @subdir;
4983             }
4984              
4985             # P.504 PERL5SHELL (Microsoft ports only)
4986             # in Chapter 19: The Command-Line Interface
4987             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4988              
4989             # P.597 PERL5SHELL (Microsoft ports only)
4990             # in Chapter 17: The Command-Line Interface
4991             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4992              
4993 0 0 0     0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
    0          
4994 0         0 # cmd.exe on Windows NT, Windows 2000
4995 0         0 if (qx{ver} =~ /\b(?:Windows NT|Windows 2000)\b/oms) {
  0         0  
4996 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
4997             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
4998             if (Ebig5hkscs::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Ebig5hkscs::fc($subdir[-1])) {
4999 0         0  
5000 0         0 # short file name (8dot3name) here-----vv
5001 0         0 my $shortleafdir = CORE::substr $dirx, 39, 8+1+3;
5002 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5003             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5004             last;
5005             }
5006             }
5007             }
5008              
5009             # an idea (not so portable, only Windows 2000 or later)
5010             elsif (0) {
5011             chomp($shortdir = qx{for %I in ("$dir") do \@echo %~sI 2>NUL});
5012             }
5013              
5014 0         0 # cmd.exe on Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
5015 0         0 elsif ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
  0         0  
5016 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5017             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5018             if (Ebig5hkscs::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Ebig5hkscs::fc($subdir[-1])) {
5019 0         0  
5020 0         0 # short file name (8dot3name) here-----vv
5021 0         0 my $shortleafdir = CORE::substr $dirx, 36, 8+1+3;
5022 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5023             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5024             last;
5025             }
5026             }
5027             }
5028              
5029 0         0 # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
5030 0         0 else {
  0         0  
5031 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad "$dir*"});
5032             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5033             if (Ebig5hkscs::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Ebig5hkscs::fc($subdir[-1])) {
5034 0         0  
5035 0         0 # short file name (8dot3name) here-----v
5036 0         0 my $shortleafdir = CORE::substr $dirx, 0, 8+1+3;
5037 0         0 CORE::substr($shortleafdir,8,1) = '.';
5038 0         0 $shortleafdir =~ s/ \. [ ]+ \z//oxms;
5039             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5040             last;
5041             }
5042             }
5043 0 0       0 }
    0          
5044 0         0  
5045             if ($shortdir eq '') {
5046             return 0;
5047 0         0 }
5048             elsif (Ebig5hkscs::fc($shortdir) eq Ebig5hkscs::fc($dir)) {
5049 0         0 return 0;
5050             }
5051             return CORE::chdir $shortdir;
5052 0         0 }
5053             else {
5054             return CORE::chdir $dir;
5055             }
5056             }
5057              
5058             #
5059             # Big5-HKSCS chr(0x5C) ended path on MSWin32
5060             #
5061 0 50 33 768   0 sub _MSWin32_5Cended_path {
5062 768 50       5216  
5063 768         4221 if ((@_ >= 1) and ($_[0] ne '')) {
5064 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
5065 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5066             if ($char[-1] =~ / \x5C \z/oxms) {
5067             return 1;
5068             }
5069 0         0 }
5070             }
5071             return undef;
5072             }
5073              
5074             #
5075             # do Big5-HKSCS file
5076             #
5077 768     0 0 1998 sub Ebig5hkscs::do($) {
5078              
5079 0         0 my($filename) = @_;
5080              
5081             my $realfilename;
5082             my $result;
5083 0         0 ITER_DO:
  0         0  
5084 0 0       0 {
5085 0         0 for my $prefix (@INC) {
5086             if ($^O eq 'MacOS') {
5087             $realfilename = "$prefix$filename";
5088 0         0 }
5089             else {
5090             $realfilename = "$prefix/$filename";
5091 0 0       0 }
5092              
5093 0         0 if (Ebig5hkscs::f($realfilename)) {
5094              
5095 0 0       0 my $script = '';
5096 0         0  
5097 0         0 if (Ebig5hkscs::e("$realfilename.e")) {
5098 0         0 my $e_mtime = (Ebig5hkscs::stat("$realfilename.e"))[9];
5099 0 0 0     0 my $mtime = (Ebig5hkscs::stat($realfilename))[9];
5100 0         0 my $module_mtime = (Ebig5hkscs::stat(__FILE__))[9];
5101             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5102             Ebig5hkscs::unlink "$realfilename.e";
5103             }
5104 0 0       0 }
5105 0         0  
5106 0 0       0 if (Ebig5hkscs::e("$realfilename.e")) {
5107 0 0       0 my $fh = gensym();
    0          
5108 0         0 if (_open_r($fh, "$realfilename.e")) {
5109             if ($^O eq 'MacOS') {
5110             CORE::eval q{
5111             CORE::require Mac::Files;
5112             Mac::Files::FSpSetFLock("$realfilename.e");
5113             };
5114             }
5115             elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5116              
5117             # P.419 File Locking
5118             # in Chapter 16: Interprocess Communication
5119             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5120              
5121             # P.524 File Locking
5122             # in Chapter 15: Interprocess Communication
5123             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5124              
5125 0         0 # (and so on)
5126 0 0       0  
5127 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5128             if ($@) {
5129             carp "Can't immediately read-lock the file: $realfilename.e";
5130             }
5131 0         0 }
5132             else {
5133 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5134 0         0 }
5135 0 0       0 local $/ = undef; # slurp mode
5136 0         0 $script = <$fh>;
5137             if ($^O eq 'MacOS') {
5138             CORE::eval q{
5139             CORE::require Mac::Files;
5140             Mac::Files::FSpRstFLock("$realfilename.e");
5141 0 0       0 };
5142             }
5143             close($fh) or die "Can't close file: $realfilename.e: $!";
5144             }
5145 0         0 }
5146 0 0       0 else {
5147 0 0       0 my $fh = gensym();
    0          
5148 0         0 if (_open_r($fh, $realfilename)) {
5149             if ($^O eq 'MacOS') {
5150             CORE::eval q{
5151             CORE::require Mac::Files;
5152             Mac::Files::FSpSetFLock($realfilename);
5153             };
5154 0         0 }
5155 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5156 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5157             if ($@) {
5158             carp "Can't immediately read-lock the file: $realfilename";
5159             }
5160 0         0 }
5161             else {
5162 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5163 0         0 }
5164 0 0       0 local $/ = undef; # slurp mode
5165 0         0 $script = <$fh>;
5166             if ($^O eq 'MacOS') {
5167             CORE::eval q{
5168             CORE::require Mac::Files;
5169             Mac::Files::FSpRstFLock($realfilename);
5170 0 0       0 };
5171             }
5172             close($fh) or die "Can't close file: $realfilename.e: $!";
5173 0 0       0 }
5174 0         0  
5175 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5176 0         0 CORE::require Big5HKSCS;
5177 0 0       0 $script = Big5HKSCS::escape_script($script);
5178 0 0       0 my $fh = gensym();
    0          
5179 0         0 open($fh, ">$realfilename.e") or die __FILE__, ": Can't write open file: $realfilename.e\n";
5180             if ($^O eq 'MacOS') {
5181             CORE::eval q{
5182             CORE::require Mac::Files;
5183             Mac::Files::FSpSetFLock("$realfilename.e");
5184             };
5185 0         0 }
5186 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5187 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5188             if ($@) {
5189             carp "Can't immediately write-lock the file: $realfilename.e";
5190             }
5191 0         0 }
5192             else {
5193 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5194 0 0       0 }
5195 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5196 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5197 0         0 print {$fh} $script;
5198             if ($^O eq 'MacOS') {
5199             CORE::eval q{
5200             CORE::require Mac::Files;
5201             Mac::Files::FSpRstFLock("$realfilename.e");
5202 0 0       0 };
5203             }
5204             close($fh) or die "Can't close file: $realfilename.e: $!";
5205             }
5206             }
5207 389     389   13311  
  389         2721  
  389         382944  
  0         0  
5208 0         0 {
5209             no strict;
5210 0         0 $result = scalar CORE::eval $script;
5211             }
5212             last ITER_DO;
5213             }
5214             }
5215 0 0       0 }
    0          
5216 0         0  
5217 0         0 if ($@) {
5218             $INC{$filename} = undef;
5219             return undef;
5220 0         0 }
5221             elsif (not $result) {
5222             return undef;
5223 0         0 }
5224 0         0 else {
5225             $INC{$filename} = $realfilename;
5226             return $result;
5227             }
5228             }
5229              
5230             #
5231             # require Big5-HKSCS file
5232             #
5233              
5234             # require
5235             # in Chapter 3: Functions
5236             # of ISBN 1-56592-149-6 Programming Perl, Second Edition.
5237             #
5238             # sub require {
5239             # my($filename) = @_;
5240             # return 1 if $INC{$filename};
5241             # my($realfilename, $result);
5242             # ITER: {
5243             # foreach $prefix (@INC) {
5244             # $realfilename = "$prefix/$filename";
5245             # if (-f $realfilename) {
5246             # $result = CORE::eval `cat $realfilename`;
5247             # last ITER;
5248             # }
5249             # }
5250             # die "Can't find $filename in \@INC";
5251             # }
5252             # die $@ if $@;
5253             # die "$filename did not return true value" unless $result;
5254             # $INC{$filename} = $realfilename;
5255             # return $result;
5256             # }
5257              
5258             # require
5259             # in Chapter 9: perlfunc: Perl builtin functions
5260             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
5261             #
5262             # sub require {
5263             # my($filename) = @_;
5264             # if (exists $INC{$filename}) {
5265             # return 1 if $INC{$filename};
5266             # die "Compilation failed in require";
5267             # }
5268             # my($realfilename, $result);
5269             # ITER: {
5270             # foreach $prefix (@INC) {
5271             # $realfilename = "$prefix/$filename";
5272             # if (-f $realfilename) {
5273             # $INC{$filename} = $realfilename;
5274             # $result = do $realfilename;
5275             # last ITER;
5276             # }
5277             # }
5278             # die "Can't find $filename in \@INC";
5279             # }
5280             # if ($@) {
5281             # $INC{$filename} = undef;
5282             # die $@;
5283             # }
5284             # elsif (!$result) {
5285             # delete $INC{$filename};
5286             # die "$filename did not return true value";
5287             # }
5288             # else {
5289             # return $result;
5290             # }
5291             # }
5292              
5293 0 0   0 0 0 sub Ebig5hkscs::require(;$) {
5294              
5295 0 0       0 local $_ = shift if @_;
5296 0 0       0  
5297 0         0 if (exists $INC{$_}) {
5298             return 1 if $INC{$_};
5299             croak "Compilation failed in require: $_";
5300             }
5301              
5302             # jcode.pl
5303             # ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
5304              
5305             # jacode.pl
5306 0 0       0 # http://search.cpan.org/dist/jacode/
5307 0         0  
5308             if (/ \b (?: jcode\.pl | jacode(?>[0-9]*)\.pl ) \z /oxms) {
5309             return CORE::require($_);
5310 0         0 }
5311              
5312             my $realfilename;
5313             my $result;
5314 0         0 ITER_REQUIRE:
  0         0  
5315 0 0       0 {
5316 0         0 for my $prefix (@INC) {
5317             if ($^O eq 'MacOS') {
5318             $realfilename = "$prefix$_";
5319 0         0 }
5320             else {
5321             $realfilename = "$prefix/$_";
5322 0 0       0 }
5323 0         0  
5324             if (Ebig5hkscs::f($realfilename)) {
5325 0         0 $INC{$_} = $realfilename;
5326              
5327 0 0       0 my $script = '';
5328 0         0  
5329 0         0 if (Ebig5hkscs::e("$realfilename.e")) {
5330 0         0 my $e_mtime = (Ebig5hkscs::stat("$realfilename.e"))[9];
5331 0 0 0     0 my $mtime = (Ebig5hkscs::stat($realfilename))[9];
5332 0         0 my $module_mtime = (Ebig5hkscs::stat(__FILE__))[9];
5333             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5334             Ebig5hkscs::unlink "$realfilename.e";
5335             }
5336 0 0       0 }
5337 0         0  
5338 0 0       0 if (Ebig5hkscs::e("$realfilename.e")) {
5339 0 0       0 my $fh = gensym();
    0          
5340 0         0 _open_r($fh, "$realfilename.e") or croak "Can't open file: $realfilename.e";
5341             if ($^O eq 'MacOS') {
5342             CORE::eval q{
5343             CORE::require Mac::Files;
5344             Mac::Files::FSpSetFLock("$realfilename.e");
5345             };
5346 0         0 }
5347 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5348 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5349             if ($@) {
5350             carp "Can't immediately read-lock the file: $realfilename.e";
5351             }
5352 0         0 }
5353             else {
5354 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5355 0         0 }
5356 0 0       0 local $/ = undef; # slurp mode
5357 0         0 $script = <$fh>;
5358             if ($^O eq 'MacOS') {
5359             CORE::eval q{
5360             CORE::require Mac::Files;
5361             Mac::Files::FSpRstFLock("$realfilename.e");
5362 0 0       0 };
5363             }
5364             close($fh) or croak "Can't close file: $realfilename: $!";
5365 0         0 }
5366 0 0       0 else {
5367 0 0       0 my $fh = gensym();
    0          
5368 0         0 _open_r($fh, $realfilename) or croak "Can't open file: $realfilename";
5369             if ($^O eq 'MacOS') {
5370             CORE::eval q{
5371             CORE::require Mac::Files;
5372             Mac::Files::FSpSetFLock($realfilename);
5373             };
5374 0         0 }
5375 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5376 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5377             if ($@) {
5378             carp "Can't immediately read-lock the file: $realfilename";
5379             }
5380 0         0 }
5381             else {
5382 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5383 0         0 }
5384 0 0       0 local $/ = undef; # slurp mode
5385 0         0 $script = <$fh>;
5386             if ($^O eq 'MacOS') {
5387             CORE::eval q{
5388             CORE::require Mac::Files;
5389             Mac::Files::FSpRstFLock($realfilename);
5390 0 0       0 };
5391             }
5392 0 0       0 close($fh) or croak "Can't close file: $realfilename: $!";
5393 0         0  
5394 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5395 0         0 CORE::require Big5HKSCS;
5396 0 0       0 $script = Big5HKSCS::escape_script($script);
5397 0 0       0 my $fh = gensym();
    0          
5398 0         0 open($fh, ">$realfilename.e") or croak "Can't write open file: $realfilename.e";
5399             if ($^O eq 'MacOS') {
5400             CORE::eval q{
5401             CORE::require Mac::Files;
5402             Mac::Files::FSpSetFLock("$realfilename.e");
5403             };
5404 0         0 }
5405 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5406 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5407             if ($@) {
5408             carp "Can't immediately write-lock the file: $realfilename.e";
5409             }
5410 0         0 }
5411             else {
5412 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5413 0 0       0 }
5414 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5415 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5416 0         0 print {$fh} $script;
5417             if ($^O eq 'MacOS') {
5418             CORE::eval q{
5419             CORE::require Mac::Files;
5420             Mac::Files::FSpRstFLock("$realfilename.e");
5421 0 0       0 };
5422             }
5423             close($fh) or croak "Can't close file: $realfilename: $!";
5424             }
5425             }
5426 389     389   5264  
  389         2247  
  389         420504  
  0         0  
5427 0         0 {
5428             no strict;
5429 0         0 $result = scalar CORE::eval $script;
5430             }
5431             last ITER_REQUIRE;
5432 0         0 }
5433             }
5434             croak "Can't find $_ in \@INC";
5435 0 0       0 }
    0          
5436 0         0  
5437 0         0 if ($@) {
5438             $INC{$_} = undef;
5439             croak $@;
5440 0         0 }
5441 0         0 elsif (not $result) {
5442             delete $INC{$_};
5443             croak "$_ did not return true value";
5444 0         0 }
5445             else {
5446             return $result;
5447             }
5448             }
5449              
5450             #
5451             # Big5-HKSCS telldir avoid warning
5452             #
5453 0     768 0 0 sub Ebig5hkscs::telldir(*) {
5454              
5455 768         2400 local $^W = 0;
5456              
5457             return CORE::telldir $_[0];
5458             }
5459              
5460             #
5461             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
5462 768 0   0 0 32304 #
5463 0 0 0     0 sub Ebig5hkscs::PREMATCH {
5464 0         0 if (defined($&)) {
5465             if (defined($1) and (CORE::substr($&,-CORE::length($1),CORE::length($1)) eq $1)) {
5466             return CORE::substr($&,0,CORE::length($&)-CORE::length($1));
5467 0         0 }
5468             else {
5469             croak 'Use of "$`", $PREMATCH, and ${^PREMATCH} need to /( capture all )/ in regexp';
5470             }
5471 0         0 }
5472             else {
5473 0         0 return '';
5474             }
5475             return $`;
5476             }
5477              
5478             #
5479             # ${^MATCH}, $MATCH, $& the string that matched
5480 0 0   0 0 0 #
5481 0 0       0 sub Ebig5hkscs::MATCH {
5482 0         0 if (defined($&)) {
5483             if (defined($1)) {
5484             return $1;
5485 0         0 }
5486             else {
5487             croak 'Use of "$&", $MATCH, and ${^MATCH} need to /( capture all )/ in regexp';
5488             }
5489 0         0 }
5490             else {
5491 0         0 return '';
5492             }
5493             return $&;
5494             }
5495              
5496             #
5497             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
5498 0     0 0 0 #
5499             sub Ebig5hkscs::POSTMATCH {
5500             return $';
5501             }
5502              
5503             #
5504             # Big5-HKSCS character to order (with parameter)
5505             #
5506 0 0   0 1 0 sub Big5HKSCS::ord(;$) {
5507              
5508 0 0       0 local $_ = shift if @_;
5509 0         0  
5510 0         0 if (/\A ($q_char) /oxms) {
5511 0         0 my @ord = unpack 'C*', $1;
5512 0         0 my $ord = 0;
5513             while (my $o = shift @ord) {
5514 0         0 $ord = $ord * 0x100 + $o;
5515             }
5516             return $ord;
5517 0         0 }
5518             else {
5519             return CORE::ord $_;
5520             }
5521             }
5522              
5523             #
5524             # Big5-HKSCS character to order (without parameter)
5525             #
5526 0 0   0 0 0 sub Big5HKSCS::ord_() {
5527 0         0  
5528 0         0 if (/\A ($q_char) /oxms) {
5529 0         0 my @ord = unpack 'C*', $1;
5530 0         0 my $ord = 0;
5531             while (my $o = shift @ord) {
5532 0         0 $ord = $ord * 0x100 + $o;
5533             }
5534             return $ord;
5535 0         0 }
5536             else {
5537             return CORE::ord $_;
5538             }
5539             }
5540              
5541             #
5542             # Big5-HKSCS reverse
5543             #
5544 0 0   0 0 0 sub Big5HKSCS::reverse(@) {
5545 0         0  
5546             if (wantarray) {
5547             return CORE::reverse @_;
5548             }
5549             else {
5550              
5551             # One of us once cornered Larry in an elevator and asked him what
5552             # problem he was solving with this, but he looked as far off into
5553             # the distance as he could in an elevator and said, "It seemed like
5554 0         0 # a good idea at the time."
5555              
5556             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
5557             }
5558             }
5559              
5560             #
5561             # Big5-HKSCS getc (with parameter, without parameter)
5562             #
5563 0     0 0 0 sub Big5HKSCS::getc(;*@) {
5564 0 0       0  
5565 0 0 0     0 my($package) = caller;
5566             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
5567 0         0 croak 'Too many arguments for Big5HKSCS::getc' if @_ and not wantarray;
  0         0  
5568 0         0  
5569 0         0 my @length = sort { $a <=> $b } keys %range_tr;
5570 0         0 my $getc = '';
5571 0 0       0 for my $length ($length[0] .. $length[-1]) {
5572 0 0       0 $getc .= CORE::getc($fh);
5573 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
5574             if ($getc =~ /\A ${Ebig5hkscs::dot_s} \z/oxms) {
5575             return wantarray ? ($getc,@_) : $getc;
5576             }
5577 0 0       0 }
5578             }
5579             return wantarray ? ($getc,@_) : $getc;
5580             }
5581              
5582             #
5583             # Big5-HKSCS length by character
5584             #
5585 0 0   0 1 0 sub Big5HKSCS::length(;$) {
5586              
5587 0         0 local $_ = shift if @_;
5588 0         0  
5589             local @_ = /\G ($q_char) /oxmsg;
5590             return scalar @_;
5591             }
5592              
5593             #
5594             # Big5-HKSCS substr by character
5595             #
5596             BEGIN {
5597              
5598             # P.232 The lvalue Attribute
5599             # in Chapter 6: Subroutines
5600             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5601              
5602             # P.336 The lvalue Attribute
5603             # in Chapter 7: Subroutines
5604             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5605              
5606             # P.144 8.4 Lvalue subroutines
5607             # in Chapter 8: perlsub: Perl subroutines
5608 389 50 0 389 1 242327 # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
5609              
5610             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
5611             # vv----------------------*******
5612             sub Big5HKSCS::substr($$;$$) %s {
5613              
5614             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5615              
5616             # If the substring is beyond either end of the string, substr() returns the undefined
5617             # value and produces a warning. When used as an lvalue, specifying a substring that
5618             # is entirely outside the string raises an exception.
5619             # http://perldoc.perl.org/functions/substr.html
5620              
5621             # A return with no argument returns the scalar value undef in scalar context,
5622             # an empty list () in list context, and (naturally) nothing at all in void
5623             # context.
5624              
5625             my $offset = $_[1];
5626             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
5627             return;
5628             }
5629              
5630             # substr($string,$offset,$length,$replacement)
5631             if (@_ == 4) {
5632             my(undef,undef,$length,$replacement) = @_;
5633             my $substr = join '', splice(@char, $offset, $length, $replacement);
5634             $_[0] = join '', @char;
5635              
5636             # return $substr; this doesn't work, don't say "return"
5637             $substr;
5638             }
5639              
5640             # substr($string,$offset,$length)
5641             elsif (@_ == 3) {
5642             my(undef,undef,$length) = @_;
5643             my $octet_offset = 0;
5644             my $octet_length = 0;
5645             if ($offset == 0) {
5646             $octet_offset = 0;
5647             }
5648             elsif ($offset > 0) {
5649             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5650             }
5651             else {
5652             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5653             }
5654             if ($length == 0) {
5655             $octet_length = 0;
5656             }
5657             elsif ($length > 0) {
5658             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
5659             }
5660             else {
5661             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
5662             }
5663             CORE::substr($_[0], $octet_offset, $octet_length);
5664             }
5665              
5666             # substr($string,$offset)
5667             else {
5668             my $octet_offset = 0;
5669             if ($offset == 0) {
5670             $octet_offset = 0;
5671             }
5672             elsif ($offset > 0) {
5673             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5674             }
5675             else {
5676             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5677             }
5678             CORE::substr($_[0], $octet_offset);
5679             }
5680             }
5681             END
5682             }
5683              
5684             #
5685             # Big5-HKSCS index by character
5686             #
5687 0     0 1 0 sub Big5HKSCS::index($$;$) {
5688 0 0       0  
5689 0         0 my $index;
5690             if (@_ == 3) {
5691             $index = Ebig5hkscs::index($_[0], $_[1], CORE::length(Big5HKSCS::substr($_[0], 0, $_[2])));
5692 0         0 }
5693             else {
5694             $index = Ebig5hkscs::index($_[0], $_[1]);
5695 0 0       0 }
5696 0         0  
5697             if ($index == -1) {
5698             return -1;
5699 0         0 }
5700             else {
5701             return Big5HKSCS::length(CORE::substr $_[0], 0, $index);
5702             }
5703             }
5704              
5705             #
5706             # Big5-HKSCS rindex by character
5707             #
5708 0     0 1 0 sub Big5HKSCS::rindex($$;$) {
5709 0 0       0  
5710 0         0 my $rindex;
5711             if (@_ == 3) {
5712             $rindex = Ebig5hkscs::rindex($_[0], $_[1], CORE::length(Big5HKSCS::substr($_[0], 0, $_[2])));
5713 0         0 }
5714             else {
5715             $rindex = Ebig5hkscs::rindex($_[0], $_[1]);
5716 0 0       0 }
5717 0         0  
5718             if ($rindex == -1) {
5719             return -1;
5720 0         0 }
5721             else {
5722             return Big5HKSCS::length(CORE::substr $_[0], 0, $rindex);
5723             }
5724             }
5725              
5726 389     389   4659 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  389         808  
  389         44175  
5727             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
5728             use vars qw($slash); $slash = 'm//';
5729              
5730             # ord() to ord() or Big5HKSCS::ord()
5731             my $function_ord = 'ord';
5732              
5733             # ord to ord or Big5HKSCS::ord_
5734             my $function_ord_ = 'ord';
5735              
5736             # reverse to reverse or Big5HKSCS::reverse
5737             my $function_reverse = 'reverse';
5738              
5739             # getc to getc or Big5HKSCS::getc
5740             my $function_getc = 'getc';
5741              
5742             # P.1023 Appendix W.9 Multibyte Anchoring
5743             # of ISBN 1-56592-224-7 CJKV Information Processing
5744              
5745             my $anchor = '';
5746 389     389   3722 $anchor = q{${Ebig5hkscs::anchor}};
  389     0   2359  
  389         22397412  
5747              
5748             use vars qw($nest);
5749              
5750             # regexp of nested parens in qqXX
5751              
5752             # P.340 Matching Nested Constructs with Embedded Code
5753             # in Chapter 7: Perl
5754             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5755              
5756             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
5757             [^\x81-\xFE\\()] |
5758             \( (?{$nest++}) |
5759             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5760             [\x81-\xFE][\x00-\xFF] |
5761             \\ [^\x81-\xFEc] |
5762             \\c[\x40-\x5F] |
5763             \\ [\x81-\xFE][\x00-\xFF] |
5764             [\x00-\xFF]
5765             }xms;
5766              
5767             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
5768             [^\x81-\xFE\\{}] |
5769             \{ (?{$nest++}) |
5770             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5771             [\x81-\xFE][\x00-\xFF] |
5772             \\ [^\x81-\xFEc] |
5773             \\c[\x40-\x5F] |
5774             \\ [\x81-\xFE][\x00-\xFF] |
5775             [\x00-\xFF]
5776             }xms;
5777              
5778             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
5779             [^\x81-\xFE\\\[\]] |
5780             \[ (?{$nest++}) |
5781             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5782             [\x81-\xFE][\x00-\xFF] |
5783             \\ [^\x81-\xFEc] |
5784             \\c[\x40-\x5F] |
5785             \\ [\x81-\xFE][\x00-\xFF] |
5786             [\x00-\xFF]
5787             }xms;
5788              
5789             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
5790             [^\x81-\xFE\\<>] |
5791             \< (?{$nest++}) |
5792             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5793             [\x81-\xFE][\x00-\xFF] |
5794             \\ [^\x81-\xFEc] |
5795             \\c[\x40-\x5F] |
5796             \\ [\x81-\xFE][\x00-\xFF] |
5797             [\x00-\xFF]
5798             }xms;
5799              
5800             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
5801             (?: ::)? (?:
5802             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5803             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5804             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5805             ))
5806             }xms;
5807              
5808             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
5809             (?: ::)? (?:
5810             (?>[0-9]+) |
5811             [^\x81-\xFEa-zA-Z_0-9\[\]] |
5812             ^[A-Z] |
5813             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5814             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5815             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5816             ))
5817             }xms;
5818              
5819             my $qq_substr = qr{(?> Char::substr | Big5HKSCS::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
5820             }xms;
5821              
5822             # regexp of nested parens in qXX
5823             my $q_paren = qr{(?{local $nest=0}) (?>(?:
5824             [^\x81-\xFE()] |
5825             [\x81-\xFE][\x00-\xFF] |
5826             \( (?{$nest++}) |
5827             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5828             [\x00-\xFF]
5829             }xms;
5830              
5831             my $q_brace = qr{(?{local $nest=0}) (?>(?:
5832             [^\x81-\xFE\{\}] |
5833             [\x81-\xFE][\x00-\xFF] |
5834             \{ (?{$nest++}) |
5835             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5836             [\x00-\xFF]
5837             }xms;
5838              
5839             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
5840             [^\x81-\xFE\[\]] |
5841             [\x81-\xFE][\x00-\xFF] |
5842             \[ (?{$nest++}) |
5843             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5844             [\x00-\xFF]
5845             }xms;
5846              
5847             my $q_angle = qr{(?{local $nest=0}) (?>(?:
5848             [^\x81-\xFE<>] |
5849             [\x81-\xFE][\x00-\xFF] |
5850             \< (?{$nest++}) |
5851             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5852             [\x00-\xFF]
5853             }xms;
5854              
5855             my $matched = '';
5856             my $s_matched = '';
5857             $matched = q{$Ebig5hkscs::matched};
5858             $s_matched = q{ Ebig5hkscs::s_matched();};
5859              
5860             my $tr_variable = ''; # variable of tr///
5861             my $sub_variable = ''; # variable of s///
5862             my $bind_operator = ''; # =~ or !~
5863              
5864             my @heredoc = (); # here document
5865             my @heredoc_delimiter = ();
5866             my $here_script = ''; # here script
5867              
5868             #
5869             # escape Big5-HKSCS script
5870 0 50   384 0 0 #
5871             sub Big5HKSCS::escape(;$) {
5872             local($_) = $_[0] if @_;
5873              
5874             # P.359 The Study Function
5875             # in Chapter 7: Perl
5876 384         1335 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5877              
5878             study $_; # Yes, I studied study yesterday.
5879              
5880             # while all script
5881              
5882             # 6.14. Matching from Where the Last Pattern Left Off
5883             # in Chapter 6. Pattern Matching
5884             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
5885             # (and so on)
5886              
5887             # one member of Tag-team
5888             #
5889             # P.128 Start of match (or end of previous match): \G
5890             # P.130 Advanced Use of \G with Perl
5891             # in Chapter 3: Overview of Regular Expression Features and Flavors
5892             # P.255 Use leading anchors
5893             # P.256 Expose ^ and \G at the front expressions
5894             # in Chapter 6: Crafting an Efficient Expression
5895             # P.315 "Tag-team" matching with /gc
5896             # in Chapter 7: Perl
5897 384         837 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5898 384         723  
5899 384         10632 my $e_script = '';
5900             while (not /\G \z/oxgc) { # member
5901             $e_script .= Big5HKSCS::escape_token();
5902 187258         307830 }
5903              
5904             return $e_script;
5905             }
5906              
5907             #
5908             # escape Big5-HKSCS token of script
5909             #
5910             sub Big5HKSCS::escape_token {
5911              
5912 384     187258 0 6814 # \n output here document
5913              
5914             my $ignore_modules = join('|', qw(
5915             utf8
5916             bytes
5917             charnames
5918             I18N::Japanese
5919             I18N::Collate
5920             I18N::JExt
5921             File::DosGlob
5922             Wild
5923             Wildcard
5924             Japanese
5925             ));
5926              
5927             # another member of Tag-team
5928             #
5929             # P.315 "Tag-team" matching with /gc
5930             # in Chapter 7: Perl
5931 187258 100 100     234969 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
5932 187258         14651775  
5933 31404 100       41335 if (/\G ( \n ) /oxgc) { # another member (and so on)
5934 31404         56434 my $heredoc = '';
5935             if (scalar(@heredoc_delimiter) >= 1) {
5936 197         283 $slash = 'm//';
5937 197         401  
5938             $heredoc = join '', @heredoc;
5939             @heredoc = ();
5940 197         337  
5941 197         383 # skip here document
5942             for my $heredoc_delimiter (@heredoc_delimiter) {
5943 205         1284 /\G .*? \n $heredoc_delimiter \n/xmsgc;
5944             }
5945 197         359 @heredoc_delimiter = ();
5946              
5947 197         291 $here_script = '';
5948             }
5949             return "\n" . $heredoc;
5950             }
5951 31404         102445  
5952             # ignore space, comment
5953             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
5954              
5955             # if (, elsif (, unless (, while (, until (, given (, and when (
5956              
5957             # given, when
5958              
5959             # P.225 The given Statement
5960             # in Chapter 15: Smart Matching and given-when
5961             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5962              
5963             # P.133 The given Statement
5964             # in Chapter 4: Statements and Declarations
5965             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5966 42620         135973  
5967 3773         5904 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
5968             $slash = 'm//';
5969             return $1;
5970             }
5971              
5972             # scalar variable ($scalar = ...) =~ tr///;
5973             # scalar variable ($scalar = ...) =~ s///;
5974              
5975             # state
5976              
5977             # P.68 Persistent, Private Variables
5978             # in Chapter 4: Subroutines
5979             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5980              
5981             # P.160 Persistent Lexically Scoped Variables: state
5982             # in Chapter 4: Statements and Declarations
5983             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5984              
5985             # (and so on)
5986 3773         11949  
5987             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
5988 170 50       467 my $e_string = e_string($1);
    50          
5989 170         7136  
5990 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
5991 0         0 $tr_variable = $e_string . e_string($1);
5992 0         0 $bind_operator = $2;
5993             $slash = 'm//';
5994             return '';
5995 0         0 }
5996 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
5997 0         0 $sub_variable = $e_string . e_string($1);
5998 0         0 $bind_operator = $2;
5999             $slash = 'm//';
6000             return '';
6001 0         0 }
6002 170         391 else {
6003             $slash = 'div';
6004             return $e_string;
6005             }
6006             }
6007              
6008 170         737 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
6009 4         11 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
6010             $slash = 'div';
6011             return q{Ebig5hkscs::PREMATCH()};
6012             }
6013              
6014 4         15 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
6015 28         54 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
6016             $slash = 'div';
6017             return q{Ebig5hkscs::MATCH()};
6018             }
6019              
6020 28         86 # $', ${'} --> $', ${'}
6021 1         3 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
6022             $slash = 'div';
6023             return $1;
6024             }
6025              
6026 1         3 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
6027 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
6028             $slash = 'div';
6029             return q{Ebig5hkscs::POSTMATCH()};
6030             }
6031              
6032             # scalar variable $scalar =~ tr///;
6033             # scalar variable $scalar =~ s///;
6034             # substr() =~ tr///;
6035 3         13 # substr() =~ s///;
6036             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
6037 2878 100       6513 my $scalar = e_string($1);
    100          
6038 2878         11500  
6039 9         17 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6040 9         15 $tr_variable = $scalar;
6041 9         16 $bind_operator = $1;
6042             $slash = 'm//';
6043             return '';
6044 9         23 }
6045 253         442 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6046 253         481 $sub_variable = $scalar;
6047 253         358 $bind_operator = $1;
6048             $slash = 'm//';
6049             return '';
6050 253         811 }
6051 2616         20210 else {
6052             $slash = 'div';
6053             return $scalar;
6054             }
6055             }
6056              
6057 2616         7265 # end of statement
6058             elsif (/\G ( [,;] ) /oxgc) {
6059             $slash = 'm//';
6060 12209         19131  
6061             # clear tr/// variable
6062             $tr_variable = '';
6063 12209         14818  
6064             # clear s/// variable
6065 12209         14540 $sub_variable = '';
6066              
6067 12209         14654 $bind_operator = '';
6068              
6069             return $1;
6070             }
6071              
6072 12209         48133 # bareword
6073             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
6074             return $1;
6075             }
6076              
6077 0         0 # $0 --> $0
6078 2         6 elsif (/\G ( \$ 0 ) /oxmsgc) {
6079             $slash = 'div';
6080             return $1;
6081 2         9 }
6082 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
6083             $slash = 'div';
6084             return $1;
6085             }
6086              
6087 0         0 # $$ --> $$
6088 1         2 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
6089             $slash = 'div';
6090             return $1;
6091             }
6092              
6093             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6094 1         10 # $1, $2, $3 --> $1, $2, $3 otherwise
6095 219         359 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
6096             $slash = 'div';
6097             return e_capture($1);
6098 219         614 }
6099 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
6100             $slash = 'div';
6101             return e_capture($1);
6102             }
6103              
6104 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6105 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
6106             $slash = 'div';
6107             return e_capture($1.'->'.$2);
6108             }
6109              
6110 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6111 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
6112             $slash = 'div';
6113             return e_capture($1.'->'.$2);
6114             }
6115              
6116 0         0 # $$foo
6117 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
6118             $slash = 'div';
6119             return e_capture($1);
6120             }
6121              
6122 0         0 # ${ foo }
6123 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
6124             $slash = 'div';
6125             return '${' . $1 . '}';
6126             }
6127              
6128 0         0 # ${ ... }
6129 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
6130             $slash = 'div';
6131             return e_capture($1);
6132             }
6133              
6134             # variable or function
6135 0         0 # $ @ % & * $ #
6136 605         1038 elsif (/\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
6137             $slash = 'div';
6138             return $1;
6139             }
6140             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
6141 605         1921 # $ @ # \ ' " / ? ( ) [ ] < >
6142 103         218 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
6143             $slash = 'div';
6144             return $1;
6145             }
6146              
6147 103         372 # while ()
6148             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
6149             return $1;
6150             }
6151              
6152             # while () --- glob
6153              
6154             # avoid "Error: Runtime exception" of perl version 5.005_03
6155 0         0  
6156             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][\x00-\xFF])+?) > (?>\s*) \) \b /oxgc) {
6157             return 'while ($_ = Ebig5hkscs::glob("' . $1 . '"))';
6158             }
6159              
6160 0         0 # while (glob)
6161             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
6162             return 'while ($_ = Ebig5hkscs::glob_)';
6163             }
6164              
6165 0         0 # while (glob(WILDCARD))
6166             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
6167             return 'while ($_ = Ebig5hkscs::glob';
6168             }
6169 0         0  
  482         1187  
6170             # doit if, doit unless, doit while, doit until, doit for, doit when
6171             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
6172 482         2039  
  19         32  
6173 19         65 # subroutines of package Ebig5hkscs
  0         0  
6174 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         17  
6175 13         35 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
6176 0         0 elsif (/\G \b Big5HKSCS::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         187  
6177 114         333 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         6  
6178 2         7 elsif (/\G \b Big5HKSCS::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Big5HKSCS::escape'; }
  2         4  
6179 2         6 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         5  
6180 2         5 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::chop'; }
  0         0  
6181 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         5  
6182 2         8 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  2         2  
6183 2         7 elsif (/\G \b Big5HKSCS::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Big5HKSCS::index'; }
  2         5  
6184 2         6 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::index'; }
  0         0  
6185 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         5  
6186 2         7 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  2         4  
6187 2         8 elsif (/\G \b Big5HKSCS::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Big5HKSCS::rindex'; }
  1         2  
6188 1         5 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::rindex'; }
  0         0  
6189 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lc'; }
  0         0  
6190 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lcfirst'; }
  0         0  
6191 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::uc'; }
  3         6  
6192             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::ucfirst'; }
6193             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::fc'; }
6194              
6195             # stacked file test operators
6196              
6197             # P.179 File Test Operators
6198             # in Chapter 12: File Tests
6199             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6200              
6201             # P.106 Named Unary and File Test Operators
6202             # in Chapter 3: Unary and Binary Operators
6203             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6204              
6205             # (and so on)
6206 3         10  
  0         0  
6207 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6208 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6209 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6210 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6211 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6212 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  1         5  
6213             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6214             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6215 1         7  
  5         10  
6216 5         22 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6217 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6218 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6219 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6220 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6221 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  1         5  
6222             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6223             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6224 1         7  
  0         0  
6225 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6226 0         0 { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1),$2)"; }
  0         0  
6227 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1),$2)"; }
  0         0  
6228             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest qw($1),"; }
6229 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest(qw($1),$2)"; }
  0         0  
6230 0         0  
  0         0  
6231 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6232 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6233 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6234 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6235 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  2         6  
6236             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
6237 2         12 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  103         217  
6238 103         350  
  0         0  
6239 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6240 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6241 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6242 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6243 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  2         7  
6244             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6245             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6246 2         35  
  6         12  
6247 6         29 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6248 0         0 { $slash = 'm//'; return "Ebig5hkscs::$1($2)"; }
  0         0  
6249 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1($2)"; }
  50         100  
6250 50         240 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1"; }
  2         5  
6251 2         9 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::$1(::"."$2)"; }
  1         3  
6252 1         5 elsif (/\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-t $2"; }
  3         7  
6253             elsif (/\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lstat'; }
6254             elsif (/\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::stat'; }
6255 3         12  
  0         0  
6256 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
6257 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
6258 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6259 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6260 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6261 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6262             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
6263 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6264 0         0  
  0         0  
6265 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
6266 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6267 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6268 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6269 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6270             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6271             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6272 0         0  
  0         0  
6273 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6274 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
6275 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
6276             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
6277 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         5  
6278 2         8  
  2         5  
6279 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         83  
6280 36         128 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
6281 2         8 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::chr'; }
  2         6  
6282 2         8 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  8         28  
6283 8         37 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
6284 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::glob'; }
  0         0  
6285 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lc_'; }
  0         0  
6286 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lcfirst_'; }
  0         0  
6287 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::uc_'; }
  0         0  
6288 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::ucfirst_'; }
  0         0  
6289 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::fc_'; }
  0         0  
6290             elsif (/\G \b lstat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::lstat_'; }
6291 0         0 elsif (/\G \b stat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::stat_'; }
  0         0  
6292             elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
6293 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::filetest_(qw($1))"; }
  0         0  
6294             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC])
6295 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::${1}_"; }
  0         0  
6296              
6297 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
6298 0         0  
  0         0  
6299 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
6300 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
6301 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::chr_'; }
  2         6  
6302 2         8 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
6303 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  4         8  
6304 4         18 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::glob_'; }
  8         28  
6305 8         35 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  2         8  
6306 2         13 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0         0  
6307 0         0 elsif (/\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::opendir$1*"; }
  87         266  
6308             elsif (/\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Ebig5hkscs::opendir$1*"; }
6309             elsif (/\G \b unlink \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ebig5hkscs::unlink'; }
6310              
6311 87         370 # chdir
6312             elsif (/\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
6313 3         7 $slash = 'm//';
6314              
6315 3         6 my $e = 'Ebig5hkscs::chdir';
6316 3         13  
6317             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6318             $e .= $1;
6319             }
6320 3 50       14  
  3 100       241  
    50          
    50          
    50          
    0          
6321             # end of chdir
6322             if (/\G (?= [,;\)\}\]] ) /oxgc) { return $e; }
6323 0         0  
6324             # chdir scalar value
6325             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return $e . e_string($1); }
6326              
6327 1 0       4 # chdir qq//
  0         0  
6328             elsif (/\G \b (qq) \b /oxgc) {
6329 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq# # --> qr # #
6330 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6331 0         0 while (not /\G \z/oxgc) {
6332 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6333 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq ( ) --> qr ( )
6334 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq { } --> qr { }
6335 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq [ ] --> qr [ ]
6336 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq < > --> qr < >
6337             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq','{','}',$2); } # qq | | --> qr { }
6338 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq * * --> qr * *
6339             }
6340             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6341             }
6342             }
6343              
6344 0 0       0 # chdir q//
  0         0  
6345             elsif (/\G \b (q) \b /oxgc) {
6346 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q# # --> qr # #
6347 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6348 0         0 while (not /\G \z/oxgc) {
6349 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6350 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q ( ) --> qr ( )
6351 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q { } --> qr { }
6352 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q [ ] --> qr [ ]
6353 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q < > --> qr < >
6354             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q','{','}',$2); } # q | | --> qr { }
6355 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q * * --> qr * *
6356             }
6357             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6358             }
6359             }
6360              
6361 0         0 # chdir ''
6362 2         5 elsif (/\G (\') /oxgc) {
6363 2 50       6 my $q_string = '';
  13 50       70  
    100          
    50          
6364 0         0 while (not /\G \z/oxgc) {
6365 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6366 2         7 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
6367             elsif (/\G \' /oxgc) { return $e . e_chdir_q('',"'","'",$q_string); }
6368 11         24 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6369             }
6370             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6371             }
6372              
6373 0         0 # chdir ""
6374 0         0 elsif (/\G (\") /oxgc) {
6375 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6376 0         0 while (not /\G \z/oxgc) {
6377 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6378 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
6379             elsif (/\G \" /oxgc) { return $e . e_chdir('','"','"',$qq_string); }
6380 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6381             }
6382             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6383             }
6384             }
6385              
6386 0         0 # split
6387             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
6388 404         917 $slash = 'm//';
6389 404         589  
6390 404         1413 my $e = '';
6391             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6392             $e .= $1;
6393             }
6394 401 100       1514  
  404 100       17467  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
6395             # end of split
6396             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Ebig5hkscs::split' . $e; }
6397 3         18  
6398             # split scalar value
6399             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Ebig5hkscs::split' . $e . e_string($1); }
6400 1         5  
6401 0         0 # split literal space
6402 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {qq$1 $2}; }
6403 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; }
6404 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; }
6405 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; }
6406 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; }
6407 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; }
6408 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {q$1 $2}; }
6409 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; }
6410 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; }
6411 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; }
6412 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; }
6413 13         63 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; }
6414             elsif (/\G ' [ ] ' /oxgc) { return 'Ebig5hkscs::split' . $e . qq {' '}; }
6415             elsif (/\G " [ ] " /oxgc) { return 'Ebig5hkscs::split' . $e . qq {" "}; }
6416              
6417 2 0       11 # split qq//
  0         0  
6418             elsif (/\G \b (qq) \b /oxgc) {
6419 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
6420 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6421 0         0 while (not /\G \z/oxgc) {
6422 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6423 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
6424 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
6425 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
6426 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
6427             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
6428 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
6429             }
6430             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6431             }
6432             }
6433              
6434 0 50       0 # split qr//
  124         1223  
6435             elsif (/\G \b (qr) \b /oxgc) {
6436 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
6437 124 50       320 else {
  124 50       5710  
    50          
    50          
    50          
    100          
    50          
    50          
6438 0         0 while (not /\G \z/oxgc) {
6439 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6440 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
6441 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
6442 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
6443 56         197 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
6444 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
6445             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
6446 68         346 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
6447             }
6448             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6449             }
6450             }
6451              
6452 0 0       0 # split q//
  0         0  
6453             elsif (/\G \b (q) \b /oxgc) {
6454 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
6455 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6456 0         0 while (not /\G \z/oxgc) {
6457 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6458 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
6459 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
6460 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
6461 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
6462             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
6463 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
6464             }
6465             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6466             }
6467             }
6468              
6469 0 50       0 # split m//
  136         1075  
6470             elsif (/\G \b (m) \b /oxgc) {
6471 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
6472 136 50       384 else {
  136 50       6189  
    50          
    50          
    50          
    100          
    50          
    50          
6473 0         0 while (not /\G \z/oxgc) {
6474 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6475 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
6476 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
6477 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
6478 56         264 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
6479 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
6480             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
6481 80         334 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
6482             }
6483             die __FILE__, ": Search pattern not terminated\n";
6484             }
6485             }
6486              
6487 0         0 # split ''
6488 0         0 elsif (/\G (\') /oxgc) {
6489 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6490 0         0 while (not /\G \z/oxgc) {
6491 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6492 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
6493             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
6494 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6495             }
6496             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6497             }
6498              
6499 0         0 # split ""
6500 0         0 elsif (/\G (\") /oxgc) {
6501 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6502 0         0 while (not /\G \z/oxgc) {
6503 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6504 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
6505             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
6506 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6507             }
6508             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6509             }
6510              
6511 0         0 # split //
6512 125         293 elsif (/\G (\/) /oxgc) {
6513 125 50       378 my $regexp = '';
  558 50       2644  
    100          
    50          
6514 0         0 while (not /\G \z/oxgc) {
6515 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
6516 125         499 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
6517             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
6518 433         960 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
6519             }
6520             die __FILE__, ": Search pattern not terminated\n";
6521             }
6522             }
6523              
6524             # tr/// or y///
6525              
6526             # about [cdsrbB]* (/B modifier)
6527             #
6528             # P.559 appendix C
6529             # of ISBN 4-89052-384-7 Programming perl
6530             # (Japanese title is: Perl puroguramingu)
6531 0         0  
6532             elsif (/\G \b ( tr | y ) \b /oxgc) {
6533             my $ope = $1;
6534 11 50       28  
6535 11         155 # $1 $2 $3 $4 $5 $6
6536 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
6537             my @tr = ($tr_variable,$2);
6538             return e_tr(@tr,'',$4,$6);
6539 0         0 }
6540 11         18 else {
6541 11 50       35 my $e = '';
  11 50       747  
    50          
    50          
    50          
    50          
6542             while (not /\G \z/oxgc) {
6543 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6544 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6545 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6546 0         0 while (not /\G \z/oxgc) {
6547 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6548 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
6549 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
6550 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
6551             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
6552 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
6553             }
6554             die __FILE__, ": Transliteration replacement not terminated\n";
6555 0         0 }
6556 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6557 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6558 0         0 while (not /\G \z/oxgc) {
6559 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6560 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
6561 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
6562 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
6563             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
6564 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
6565             }
6566             die __FILE__, ": Transliteration replacement not terminated\n";
6567 0         0 }
6568 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6569 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6570 0         0 while (not /\G \z/oxgc) {
6571 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6572 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
6573 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
6574 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
6575             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
6576 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
6577             }
6578             die __FILE__, ": Transliteration replacement not terminated\n";
6579 0         0 }
6580 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6581 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6582 0         0 while (not /\G \z/oxgc) {
6583 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6584 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
6585 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
6586 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
6587             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
6588 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
6589             }
6590             die __FILE__, ": Transliteration replacement not terminated\n";
6591             }
6592 0         0 # $1 $2 $3 $4 $5 $6
6593 11         46 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
6594             my @tr = ($tr_variable,$2);
6595             return e_tr(@tr,'',$4,$6);
6596 11         35 }
6597             }
6598             die __FILE__, ": Transliteration pattern not terminated\n";
6599             }
6600             }
6601              
6602 0         0 # qq//
6603             elsif (/\G \b (qq) \b /oxgc) {
6604             my $ope = $1;
6605 5897 100       16150  
6606 5897         11859 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
6607 40         662 if (/\G (\#) /oxgc) { # qq# #
6608 40 100       113 my $qq_string = '';
  1948 50       8370  
    100          
    50          
6609 80         170 while (not /\G \z/oxgc) {
6610 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6611 40         384 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
6612             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
6613 1828         7191 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6614             }
6615             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6616             }
6617 0         0  
6618 5857         8285 else {
6619 5857 50       14339 my $e = '';
  5857 50       22695  
    100          
    50          
    100          
    50          
6620             while (not /\G \z/oxgc) {
6621             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6622              
6623 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
6624 0         0 elsif (/\G (\() /oxgc) { # qq ( )
6625 0         0 my $qq_string = '';
6626 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6627 0         0 while (not /\G \z/oxgc) {
6628 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6629             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
6630 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6631 0         0 elsif (/\G (\)) /oxgc) {
6632             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
6633 0         0 else { $qq_string .= $1; }
6634             }
6635 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6636             }
6637             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6638             }
6639              
6640 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
6641 5775         8804 elsif (/\G (\{) /oxgc) { # qq { }
6642 5775         8857 my $qq_string = '';
6643 5775 100       12206 local $nest = 1;
  246229 50       820277  
    100          
    100          
    50          
6644 720         1550 while (not /\G \z/oxgc) {
6645 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1384         2111  
6646             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
6647 1384 100       2469 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  7159         11801  
6648 5775         12712 elsif (/\G (\}) /oxgc) {
6649             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
6650 1384         2892 else { $qq_string .= $1; }
6651             }
6652 236966         485502 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6653             }
6654             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6655             }
6656              
6657 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
6658 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
6659 0         0 my $qq_string = '';
6660 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6661 0         0 while (not /\G \z/oxgc) {
6662 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6663             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
6664 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6665 0         0 elsif (/\G (\]) /oxgc) {
6666             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
6667 0         0 else { $qq_string .= $1; }
6668             }
6669 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6670             }
6671             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6672             }
6673              
6674 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
6675 62         112 elsif (/\G (\<) /oxgc) { # qq < >
6676 62         108 my $qq_string = '';
6677 62 100       259 local $nest = 1;
  2040 50       8903  
    100          
    100          
    50          
6678 22         51 while (not /\G \z/oxgc) {
6679 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  2         4  
6680             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
6681 2 100       3 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  64         150  
6682 62         164 elsif (/\G (\>) /oxgc) {
6683             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
6684 2         4 else { $qq_string .= $1; }
6685             }
6686 1952         5450 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6687             }
6688             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6689             }
6690              
6691 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
6692 20         33 elsif (/\G (\S) /oxgc) { # qq * *
6693 20         23 my $delimiter = $1;
6694 20 50       67 my $qq_string = '';
  840 50       2344  
    100          
    50          
6695 0         0 while (not /\G \z/oxgc) {
6696 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6697 20         41 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
6698             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
6699 820         1562 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6700             }
6701             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6702 0         0 }
6703             }
6704             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6705             }
6706             }
6707              
6708 0         0 # qr//
6709 184 50       495 elsif (/\G \b (qr) \b /oxgc) {
6710 184         804 my $ope = $1;
6711             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
6712             return e_qr($ope,$1,$3,$2,$4);
6713 0         0 }
6714 184         269 else {
6715 184 50       479 my $e = '';
  184 50       4860  
    100          
    50          
    50          
    100          
    50          
    50          
6716 0         0 while (not /\G \z/oxgc) {
6717 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6718 1         7 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
6719 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
6720 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
6721 76         217 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
6722 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
6723             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
6724 107         323 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
6725             }
6726             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6727             }
6728             }
6729              
6730 0         0 # qw//
6731 34 50       109 elsif (/\G \b (qw) \b /oxgc) {
6732 34         110 my $ope = $1;
6733             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
6734             return e_qw($ope,$1,$3,$2);
6735 0         0 }
6736 34         72 else {
6737 34 50       118 my $e = '';
  34 50       214  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6738             while (not /\G \z/oxgc) {
6739 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6740 34         119  
6741             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6742 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6743 0         0  
6744             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6745 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6746 0         0  
6747             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6748 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6749 0         0  
6750             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6751 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6752 0         0  
6753             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6754 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6755             }
6756             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6757             }
6758             }
6759              
6760 0         0 # qx//
6761 3 50       15 elsif (/\G \b (qx) \b /oxgc) {
6762 3         79 my $ope = $1;
6763             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
6764             return e_qq($ope,$1,$3,$2);
6765 0         0 }
6766 3         9 else {
6767 3 50       15 my $e = '';
  3 50       414  
    100          
    50          
    50          
    50          
    50          
6768 0         0 while (not /\G \z/oxgc) {
6769 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6770 2         10 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
6771 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
6772 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
6773 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
6774             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
6775 1         5 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
6776             }
6777             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6778             }
6779             }
6780              
6781 0         0 # q//
6782             elsif (/\G \b (q) \b /oxgc) {
6783             my $ope = $1;
6784              
6785             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
6786              
6787             # avoid "Error: Runtime exception" of perl version 5.005_03
6788 606 50       1975 # (and so on)
6789 606         3453  
6790 0         0 if (/\G (\#) /oxgc) { # q# #
6791 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6792 0         0 while (not /\G \z/oxgc) {
6793 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6794 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
6795             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
6796 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6797             }
6798             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6799             }
6800 0         0  
6801 606         1243 else {
6802 606 50       2058 my $e = '';
  606 100       3853  
    100          
    50          
    100          
    50          
6803             while (not /\G \z/oxgc) {
6804             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6805              
6806 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
6807 1         3 elsif (/\G (\() /oxgc) { # q ( )
6808 1         2 my $q_string = '';
6809 1 50       4 local $nest = 1;
  7 50       47  
    50          
    50          
    100          
    50          
6810 0         0 while (not /\G \z/oxgc) {
6811 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6812 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
6813             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
6814 0 50       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  1         3  
6815 1         2 elsif (/\G (\)) /oxgc) {
6816             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
6817 0         0 else { $q_string .= $1; }
6818             }
6819 6         15 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6820             }
6821             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6822             }
6823              
6824 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
6825 599         1119 elsif (/\G (\{) /oxgc) { # q { }
6826 599         1223 my $q_string = '';
6827 599 50       1822 local $nest = 1;
  8267 50       36519  
    50          
    100          
    100          
    50          
6828 0         0 while (not /\G \z/oxgc) {
6829 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6830 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  114         196  
6831             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
6832 114 100       227 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  713         1724  
6833 599         1962 elsif (/\G (\}) /oxgc) {
6834             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
6835 114         264 else { $q_string .= $1; }
6836             }
6837 7440         14993 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6838             }
6839             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6840             }
6841              
6842 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
6843 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
6844 0         0 my $q_string = '';
6845 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
6846 0         0 while (not /\G \z/oxgc) {
6847 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6848 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
6849             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
6850 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
6851 0         0 elsif (/\G (\]) /oxgc) {
6852             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
6853 0         0 else { $q_string .= $1; }
6854             }
6855 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6856             }
6857             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6858             }
6859              
6860 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
6861 5         13 elsif (/\G (\<) /oxgc) { # q < >
6862 5         11 my $q_string = '';
6863 5 50       20 local $nest = 1;
  82 50       405  
    50          
    50          
    100          
    50          
6864 0         0 while (not /\G \z/oxgc) {
6865 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6866 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
6867             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
6868 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         15  
6869 5         15 elsif (/\G (\>) /oxgc) {
6870             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
6871 0         0 else { $q_string .= $1; }
6872             }
6873 77         154 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6874             }
6875             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6876             }
6877              
6878 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
6879 1         3 elsif (/\G (\S) /oxgc) { # q * *
6880 1         2 my $delimiter = $1;
6881 1 50       4 my $q_string = '';
  14 50       75  
    100          
    50          
6882 0         0 while (not /\G \z/oxgc) {
6883 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6884 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
6885             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
6886 13         28 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6887             }
6888             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6889 0         0 }
6890             }
6891             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6892             }
6893             }
6894              
6895 0         0 # m//
6896 491 50       1327 elsif (/\G \b (m) \b /oxgc) {
6897 491         4013 my $ope = $1;
6898             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
6899             return e_qr($ope,$1,$3,$2,$4);
6900 0         0 }
6901 491         799 else {
6902 491 50       1285 my $e = '';
  491 50       21206  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6903 0         0 while (not /\G \z/oxgc) {
6904 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6905 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
6906 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
6907 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
6908 92         418 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
6909 87         385 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
6910 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
6911             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
6912 312         1116 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
6913             }
6914             die __FILE__, ": Search pattern not terminated\n";
6915             }
6916             }
6917              
6918             # s///
6919              
6920             # about [cegimosxpradlunbB]* (/cg modifier)
6921             #
6922             # P.67 Pattern-Matching Operators
6923             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
6924 0         0  
6925             elsif (/\G \b (s) \b /oxgc) {
6926             my $ope = $1;
6927 290 100       1026  
6928 290         4356 # $1 $2 $3 $4 $5 $6
6929             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
6930             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
6931 1         6 }
6932 289         565 else {
6933 289 50       915 my $e = '';
  289 50       28312  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6934             while (not /\G \z/oxgc) {
6935 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6936 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6937 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6938             while (not /\G \z/oxgc) {
6939 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6940 0         0 # $1 $2 $3 $4
6941 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6942 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6943 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6944 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6945 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6946 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6947 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6948             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6949 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6950             }
6951             die __FILE__, ": Substitution replacement not terminated\n";
6952 0         0 }
6953 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6954 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6955             while (not /\G \z/oxgc) {
6956 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6957 0         0 # $1 $2 $3 $4
6958 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6959 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6960 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6961 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6962 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6963 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6964 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6965             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6966 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6967             }
6968             die __FILE__, ": Substitution replacement not terminated\n";
6969 0         0 }
6970 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6971 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
6972             while (not /\G \z/oxgc) {
6973 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6974 0         0 # $1 $2 $3 $4
6975 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6976 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6977 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6978 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6979 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6980             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6981 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6982             }
6983             die __FILE__, ": Substitution replacement not terminated\n";
6984 0         0 }
6985 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6986 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6987             while (not /\G \z/oxgc) {
6988 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6989 0         0 # $1 $2 $3 $4
6990 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6991 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6992 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6993 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6994 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6995 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6996 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6997             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6998 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6999             }
7000             die __FILE__, ": Substitution replacement not terminated\n";
7001             }
7002 0         0 # $1 $2 $3 $4 $5 $6
7003             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
7004             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7005             }
7006 96         267 # $1 $2 $3 $4 $5 $6
7007             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7008             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
7009             }
7010 2         23 # $1 $2 $3 $4 $5 $6
7011             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7012             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7013             }
7014 0         0 # $1 $2 $3 $4 $5 $6
7015             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7016             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7017 191         868 }
7018             }
7019             die __FILE__, ": Substitution pattern not terminated\n";
7020             }
7021             }
7022 0         0  
7023 1         8 # do
7024 0         0 elsif (/\G \b do (?= (?>\s*) \{ ) /oxmsgc) { return 'do'; }
7025 0         0 elsif (/\G \b do (?= (?>\s+) (?: q | qq | qx ) \b) /oxmsgc) { return 'Ebig5hkscs::do'; }
7026 0         0 elsif (/\G \b do (?= (?>\s+) (?>\w+)) /oxmsgc) { return 'do'; }
7027             elsif (/\G \b do (?= (?>\s*) \$ (?> \w+ (?: ::\w+)* ) \( ) /oxmsgc) { return 'do'; }
7028             elsif (/\G \b do \b /oxmsgc) { return 'Ebig5hkscs::do'; }
7029 2         10  
7030 0         0 # require ignore module
7031 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
7032             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# require$1\n$2"; }
7033             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
7034 0         0  
7035 0         0 # require version number
7036 0         0 elsif (/\G \b require (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7037             elsif (/\G \b require (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7038             elsif (/\G \b require (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7039 0         0  
7040             # require bare package name
7041             elsif (/\G \b require (?>\s+) ((?>[A-Za-z_]\w* (?: :: [A-Za-z_]\w*)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7042 18         130  
7043 0         0 # require else
7044             elsif (/\G \b require (?>\s*) ; /oxmsgc) { return 'Ebig5hkscs::require;'; }
7045             elsif (/\G \b require \b /oxmsgc) { return 'Ebig5hkscs::require'; }
7046 1         6  
7047 70         641 # use strict; --> use strict; no strict qw(refs);
7048 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
7049             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
7050             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
7051              
7052 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
7053 3         48 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7054             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
7055             return "use $1; no strict qw(refs);";
7056 0         0 }
7057             else {
7058             return "use $1;";
7059             }
7060 3 0 0     20 }
      0        
7061 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7062             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
7063             return "use $1; no strict qw(refs);";
7064 0         0 }
7065             else {
7066             return "use $1;";
7067             }
7068             }
7069 0         0  
7070 2         16 # ignore use module
7071 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
7072             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# use$1\n$2"; }
7073             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
7074 0         0  
7075 0         0 # ignore no module
7076 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
7077             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# no$1\n$2"; }
7078             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
7079 0         0  
7080 0         0 # use without import
7081 0         0 elsif (/\G \b use (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7082 0         0 elsif (/\G \b use (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7083 0         0 elsif (/\G \b use (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7084 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7085 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7086 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7087 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7088 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7089             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7090             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7091 0         0  
7092             # use with import no parameter
7093             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_use_noparam($1); }
7094 0         0  
7095 0         0 # use with import parameters
7096 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7097 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\xFE']* \') (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7098 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\xFE"]* \") (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7099 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7100 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\{) (?:$q_char)*? \}) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7101 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\[) (?:$q_char)*? \]) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7102 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\<) [^\x81-\xFE>]* \>) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7103             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7104             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\S) (?:$q_char)*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7105 0         0  
7106 0         0 # no without unimport
7107 0         0 elsif (/\G \b no (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7108 0         0 elsif (/\G \b no (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7109 0         0 elsif (/\G \b no (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7110 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7111 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7112 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7113 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7114 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7115             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7116             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7117 0         0  
7118             # no with unimport no parameter
7119             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_no_noparam($1); }
7120 0         0  
7121 0         0 # no with unimport parameters
7122 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7123 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\xFE']* \') (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7124 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\xFE"]* \") (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7125 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7126 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\{) (?:$q_char)*? \}) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7127 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\[) (?:$q_char)*? \]) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7128 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\<) [^\x81-\xFE>]* \>) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7129             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7130             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\S) (?:$q_char)*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7131 0         0  
7132             # use else
7133             elsif (/\G \b use \b /oxmsgc) { return "use"; }
7134 0         0  
7135             # use else
7136             elsif (/\G \b no \b /oxmsgc) { return "no"; }
7137              
7138 2         12 # ''
7139 3177         7600 elsif (/\G (?
7140 3177 100       8546 my $q_string = '';
  15708 100       55571  
    100          
    50          
7141 8         23 while (not /\G \z/oxgc) {
7142 48         123 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
7143 3177         7913 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
7144             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
7145 12475         28562 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7146             }
7147             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7148             }
7149              
7150 0         0 # ""
7151 3404         23733 elsif (/\G (\") /oxgc) {
7152 3404 100       9447 my $qq_string = '';
  72029 100       211034  
    100          
    50          
7153 109         254 while (not /\G \z/oxgc) {
7154 14         34 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7155 3404         8933 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
7156             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
7157 68502         137353 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
7158             }
7159             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7160             }
7161              
7162 0         0 # ``
7163 37         144 elsif (/\G (\`) /oxgc) {
7164 37 50       158 my $qx_string = '';
  313 50       1878  
    100          
    50          
7165 0         0 while (not /\G \z/oxgc) {
7166 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
7167 37         160 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
7168             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
7169 276         720 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
7170             }
7171             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7172             }
7173              
7174 0         0 # // --- not divide operator (num / num), not defined-or
7175 1231         3243 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
7176 1231 100       3525 my $regexp = '';
  12602 50       44950  
    100          
    50          
7177 11         36 while (not /\G \z/oxgc) {
7178 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7179 1231         3400 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
7180             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
7181 11360         24593 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7182             }
7183             die __FILE__, ": Search pattern not terminated\n";
7184             }
7185              
7186 0         0 # ?? --- not conditional operator (condition ? then : else)
7187 92         221 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
7188 92 50       206 my $regexp = '';
  266 50       989  
    100          
    50          
7189 0         0 while (not /\G \z/oxgc) {
7190 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7191 92         218 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
7192             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
7193 174         433 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7194             }
7195             die __FILE__, ": Search pattern not terminated\n";
7196             }
7197 0         0  
  0         0  
7198             # <<>> (a safer ARGV)
7199             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
7200 0         0  
  0         0  
7201             # << (bit shift) --- not here document
7202             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
7203              
7204 0         0 # <<~'HEREDOC'
7205 6         13 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
7206 6         12 $slash = 'm//';
7207             my $here_quote = $1;
7208             my $delimiter = $2;
7209 6 50       10  
7210 6         11 # get here document
7211 6         31 if ($here_script eq '') {
7212             $here_script = CORE::substr $_, pos $_;
7213 6 50       29 $here_script =~ s/.*?\n//oxm;
7214 6         64 }
7215 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7216 6         7 my $heredoc = $1;
7217 6         45 my $indent = $2;
7218 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
7219             push @heredoc, $heredoc . qq{\n$delimiter\n};
7220             push @heredoc_delimiter, qq{\\s*$delimiter};
7221 6         14 }
7222             else {
7223 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7224             }
7225             return qq{<<'$delimiter'};
7226             }
7227              
7228             # <<~\HEREDOC
7229              
7230             # P.66 2.6.6. "Here" Documents
7231             # in Chapter 2: Bits and Pieces
7232             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7233              
7234             # P.73 "Here" Documents
7235             # in Chapter 2: Bits and Pieces
7236             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7237 6         24  
7238 3         9 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
7239 3         6 $slash = 'm//';
7240             my $here_quote = $1;
7241             my $delimiter = $2;
7242 3 50       6  
7243 3         8 # get here document
7244 3         12 if ($here_script eq '') {
7245             $here_script = CORE::substr $_, pos $_;
7246 3 50       15 $here_script =~ s/.*?\n//oxm;
7247 3         36 }
7248 3         6 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7249 3         5 my $heredoc = $1;
7250 3         35 my $indent = $2;
7251 3         11 $heredoc =~ s{^$indent}{}msg; # no /ox
7252             push @heredoc, $heredoc . qq{\n$delimiter\n};
7253             push @heredoc_delimiter, qq{\\s*$delimiter};
7254 3         8 }
7255             else {
7256 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7257             }
7258             return qq{<<\\$delimiter};
7259             }
7260              
7261 3         11 # <<~"HEREDOC"
7262 6         12 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
7263 6         21 $slash = 'm//';
7264             my $here_quote = $1;
7265             my $delimiter = $2;
7266 6 50       9  
7267 6         13 # get here document
7268 6         22 if ($here_script eq '') {
7269             $here_script = CORE::substr $_, pos $_;
7270 6 50       28 $here_script =~ s/.*?\n//oxm;
7271 6         53 }
7272 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7273 6         6 my $heredoc = $1;
7274 6         42 my $indent = $2;
7275 6         15 $heredoc =~ s{^$indent}{}msg; # no /ox
7276             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7277             push @heredoc_delimiter, qq{\\s*$delimiter};
7278 6         12 }
7279             else {
7280 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7281             }
7282             return qq{<<"$delimiter"};
7283             }
7284              
7285 6         33 # <<~HEREDOC
7286 3         6 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
7287 3         7 $slash = 'm//';
7288             my $here_quote = $1;
7289             my $delimiter = $2;
7290 3 50       4  
7291 3         7 # get here document
7292 3         13 if ($here_script eq '') {
7293             $here_script = CORE::substr $_, pos $_;
7294 3 50       15 $here_script =~ s/.*?\n//oxm;
7295 3         34 }
7296 3         4 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7297 3         6 my $heredoc = $1;
7298 3         30 my $indent = $2;
7299 3         9 $heredoc =~ s{^$indent}{}msg; # no /ox
7300             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7301             push @heredoc_delimiter, qq{\\s*$delimiter};
7302 3         7 }
7303             else {
7304 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7305             }
7306             return qq{<<$delimiter};
7307             }
7308              
7309 3         12 # <<~`HEREDOC`
7310 6         12 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
7311 6         15 $slash = 'm//';
7312             my $here_quote = $1;
7313             my $delimiter = $2;
7314 6 50       9  
7315 6         13 # get here document
7316 6         21 if ($here_script eq '') {
7317             $here_script = CORE::substr $_, pos $_;
7318 6 50       40 $here_script =~ s/.*?\n//oxm;
7319 6         55 }
7320 6         12 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7321 6         16 my $heredoc = $1;
7322 6         46 my $indent = $2;
7323 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
7324             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7325             push @heredoc_delimiter, qq{\\s*$delimiter};
7326 6         13 }
7327             else {
7328 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7329             }
7330             return qq{<<`$delimiter`};
7331             }
7332              
7333 6         32 # <<'HEREDOC'
7334 86         190 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
7335 86         191 $slash = 'm//';
7336             my $here_quote = $1;
7337             my $delimiter = $2;
7338 86 100       150  
7339 86         195 # get here document
7340 83         493 if ($here_script eq '') {
7341             $here_script = CORE::substr $_, pos $_;
7342 83 50       445 $here_script =~ s/.*?\n//oxm;
7343 86         668 }
7344 86         296 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7345             push @heredoc, $1 . qq{\n$delimiter\n};
7346             push @heredoc_delimiter, $delimiter;
7347 86         174 }
7348             else {
7349 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7350             }
7351             return $here_quote;
7352             }
7353              
7354             # <<\HEREDOC
7355              
7356             # P.66 2.6.6. "Here" Documents
7357             # in Chapter 2: Bits and Pieces
7358             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7359              
7360             # P.73 "Here" Documents
7361             # in Chapter 2: Bits and Pieces
7362             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7363 86         335  
7364 2         6 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
7365 2         5 $slash = 'm//';
7366             my $here_quote = $1;
7367             my $delimiter = $2;
7368 2 100       4  
7369 2         6 # get here document
7370 1         7 if ($here_script eq '') {
7371             $here_script = CORE::substr $_, pos $_;
7372 1 50       7 $here_script =~ s/.*?\n//oxm;
7373 2         27 }
7374 2         8 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7375             push @heredoc, $1 . qq{\n$delimiter\n};
7376             push @heredoc_delimiter, $delimiter;
7377 2         4 }
7378             else {
7379 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7380             }
7381             return $here_quote;
7382             }
7383              
7384 2         8 # <<"HEREDOC"
7385 39         100 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
7386 39         105 $slash = 'm//';
7387             my $here_quote = $1;
7388             my $delimiter = $2;
7389 39 100       75  
7390 39         105 # get here document
7391 38         246 if ($here_script eq '') {
7392             $here_script = CORE::substr $_, pos $_;
7393 38 50       219 $here_script =~ s/.*?\n//oxm;
7394 39         497 }
7395 39         126 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7396             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7397             push @heredoc_delimiter, $delimiter;
7398 39         83 }
7399             else {
7400 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7401             }
7402             return $here_quote;
7403             }
7404              
7405 39         174 # <
7406 54         146 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
7407 54         203 $slash = 'm//';
7408             my $here_quote = $1;
7409             my $delimiter = $2;
7410 54 100       106  
7411 54         153 # get here document
7412 51         297 if ($here_script eq '') {
7413             $here_script = CORE::substr $_, pos $_;
7414 51 50       358 $here_script =~ s/.*?\n//oxm;
7415 54         714 }
7416 54         228 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7417             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7418             push @heredoc_delimiter, $delimiter;
7419 54         119 }
7420             else {
7421 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7422             }
7423             return $here_quote;
7424             }
7425              
7426 54         241 # <<`HEREDOC`
7427 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
7428 0         0 $slash = 'm//';
7429             my $here_quote = $1;
7430             my $delimiter = $2;
7431 0 0       0  
7432 0         0 # get here document
7433 0         0 if ($here_script eq '') {
7434             $here_script = CORE::substr $_, pos $_;
7435 0 0       0 $here_script =~ s/.*?\n//oxm;
7436 0         0 }
7437 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7438             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7439             push @heredoc_delimiter, $delimiter;
7440 0         0 }
7441             else {
7442 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7443             }
7444             return $here_quote;
7445             }
7446              
7447 0         0 # <<= <=> <= < operator
7448             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
7449             return $1;
7450             }
7451              
7452 13         113 #
7453             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
7454             return $1;
7455             }
7456              
7457             # --- glob
7458              
7459             # avoid "Error: Runtime exception" of perl version 5.005_03
7460 0         0  
7461             elsif (/\G < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][\x00-\xFF])+?) > /oxgc) {
7462             return 'Ebig5hkscs::glob("' . $1 . '")';
7463             }
7464 0         0  
7465             # __DATA__
7466             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
7467 0         0  
7468             # __END__
7469             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
7470              
7471             # \cD Control-D
7472              
7473             # P.68 2.6.8. Other Literal Tokens
7474             # in Chapter 2: Bits and Pieces
7475             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7476              
7477             # P.76 Other Literal Tokens
7478             # in Chapter 2: Bits and Pieces
7479 384         3162 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7480              
7481             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
7482 0         0  
7483             # \cZ Control-Z
7484             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
7485              
7486             # any operator before div
7487             elsif (/\G (
7488             -- | \+\+ |
7489 0         0 [\)\}\]]
  14161         32646  
7490              
7491             ) /oxgc) { $slash = 'div'; return $1; }
7492              
7493             # yada-yada or triple-dot operator
7494             elsif (/\G (
7495 14161         70897 \.\.\.
  7         18  
7496              
7497             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
7498              
7499             # any operator before m//
7500              
7501             # //, //= (defined-or)
7502              
7503             # P.164 Logical Operators
7504             # in Chapter 10: More Control Structures
7505             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7506              
7507             # P.119 C-Style Logical (Short-Circuit) Operators
7508             # in Chapter 3: Unary and Binary Operators
7509             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7510              
7511             # (and so on)
7512              
7513             # ~~
7514              
7515             # P.221 The Smart Match Operator
7516             # in Chapter 15: Smart Matching and given-when
7517             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7518              
7519             # P.112 Smartmatch Operator
7520             # in Chapter 3: Unary and Binary Operators
7521             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7522              
7523             # (and so on)
7524              
7525             elsif (/\G ((?>
7526              
7527             !~~ | !~ | != | ! |
7528             %= | % |
7529             &&= | && | &= | &\.= | &\. | & |
7530             -= | -> | - |
7531             :(?>\s*)= |
7532             : |
7533             <<>> |
7534             <<= | <=> | <= | < |
7535             == | => | =~ | = |
7536             >>= | >> | >= | > |
7537             \*\*= | \*\* | \*= | \* |
7538             \+= | \+ |
7539             \.\. | \.= | \. |
7540             \/\/= | \/\/ |
7541             \/= | \/ |
7542             \? |
7543             \\ |
7544             \^= | \^\.= | \^\. | \^ |
7545             \b x= |
7546             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
7547             ~~ | ~\. | ~ |
7548             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
7549             \b(?: print )\b |
7550              
7551 7         32 [,;\(\{\[]
  23792         51622  
7552              
7553             )) /oxgc) { $slash = 'm//'; return $1; }
7554 23792         115658  
  37734         80337  
7555             # other any character
7556             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
7557              
7558 37734         200747 # system error
7559             else {
7560             die __FILE__, ": Oops, this shouldn't happen!\n";
7561             }
7562             }
7563              
7564 0     3097 0 0 # escape Big5-HKSCS string
7565 3097         12476 sub e_string {
7566             my($string) = @_;
7567 3097         4764 my $e_string = '';
7568              
7569             local $slash = 'm//';
7570              
7571             # P.1024 Appendix W.10 Multibyte Processing
7572             # of ISBN 1-56592-224-7 CJKV Information Processing
7573 3097         4749 # (and so on)
7574              
7575             my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\$q_char|$q_char) /oxmsg;
7576 3097 100 66     28462  
7577 3097 50       15779 # without { ... }
7578 3018         7354 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
7579             if ($string !~ /<
7580             return $string;
7581             }
7582             }
7583 3018         8282  
7584 79 50       258 E_STRING_LOOP:
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
7585             while ($string !~ /\G \z/oxgc) {
7586             if (0) {
7587             }
7588 606         110543  
7589 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Ebig5hkscs::PREMATCH()]}
7590 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
7591             $e_string .= q{Ebig5hkscs::PREMATCH()};
7592             $slash = 'div';
7593             }
7594              
7595 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Ebig5hkscs::MATCH()]}
7596 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
7597             $e_string .= q{Ebig5hkscs::MATCH()};
7598             $slash = 'div';
7599             }
7600              
7601 0         0 # $', ${'} --> $', ${'}
7602 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
7603             $e_string .= $1;
7604             $slash = 'div';
7605             }
7606              
7607 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Ebig5hkscs::POSTMATCH()]}
7608 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
7609             $e_string .= q{Ebig5hkscs::POSTMATCH()};
7610             $slash = 'div';
7611             }
7612              
7613 0         0 # bareword
7614 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
7615             $e_string .= $1;
7616             $slash = 'div';
7617             }
7618              
7619 0         0 # $0 --> $0
7620 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
7621             $e_string .= $1;
7622             $slash = 'div';
7623 0         0 }
7624 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
7625             $e_string .= $1;
7626             $slash = 'div';
7627             }
7628              
7629 0         0 # $$ --> $$
7630 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
7631             $e_string .= $1;
7632             $slash = 'div';
7633             }
7634              
7635             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7636 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7637 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
7638             $e_string .= e_capture($1);
7639             $slash = 'div';
7640 0         0 }
7641 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
7642             $e_string .= e_capture($1);
7643             $slash = 'div';
7644             }
7645              
7646 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7647 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
7648             $e_string .= e_capture($1.'->'.$2);
7649             $slash = 'div';
7650             }
7651              
7652 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7653 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
7654             $e_string .= e_capture($1.'->'.$2);
7655             $slash = 'div';
7656             }
7657              
7658 0         0 # $$foo
7659 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
7660             $e_string .= e_capture($1);
7661             $slash = 'div';
7662             }
7663              
7664 0         0 # ${ foo }
7665 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
7666             $e_string .= '${' . $1 . '}';
7667             $slash = 'div';
7668             }
7669              
7670 0         0 # ${ ... }
7671 3         11 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
7672             $e_string .= e_capture($1);
7673             $slash = 'div';
7674             }
7675              
7676             # variable or function
7677 3         19 # $ @ % & * $ #
7678 0         0 elsif ($string =~ /\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
7679             $e_string .= $1;
7680             $slash = 'div';
7681             }
7682             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
7683 0         0 # $ @ # \ ' " / ? ( ) [ ] < >
7684 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
7685             $e_string .= $1;
7686             $slash = 'div';
7687             }
7688 0         0  
  0         0  
7689 0         0 # subroutines of package Ebig5hkscs
  0         0  
7690 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
7691 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7692 0         0 elsif ($string =~ /\G \b Big5HKSCS::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7693 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
7694 0         0 elsif ($string =~ /\G \b Big5HKSCS::eval \b /oxgc) { $e_string .= 'eval Big5HKSCS::escape'; $slash = 'm//'; }
  0         0  
7695 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
7696 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Ebig5hkscs::chop'; $slash = 'm//'; }
  0         0  
7697 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
7698 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
7699 0         0 elsif ($string =~ /\G \b Big5HKSCS::index \b /oxgc) { $e_string .= 'Big5HKSCS::index'; $slash = 'm//'; }
  0         0  
7700 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Ebig5hkscs::index'; $slash = 'm//'; }
  0         0  
7701 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
7702 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
7703 0         0 elsif ($string =~ /\G \b Big5HKSCS::rindex \b /oxgc) { $e_string .= 'Big5HKSCS::rindex'; $slash = 'm//'; }
  0         0  
7704 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Ebig5hkscs::rindex'; $slash = 'm//'; }
  0         0  
7705 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::lc'; $slash = 'm//'; }
  0         0  
7706 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::lcfirst'; $slash = 'm//'; }
  0         0  
7707 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::uc'; $slash = 'm//'; }
  0         0  
7708             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::ucfirst'; $slash = 'm//'; }
7709 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::fc'; $slash = 'm//'; }
  0         0  
7710 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7711 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7712 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7713 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7714 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7715 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         6  
7716             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//'; }
7717             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//'; }
7718 1         4  
  1         6  
7719 1         3 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7720 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7721 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7722 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7723 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7724 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  1         7  
7725             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//'; }
7726             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//'; }
7727 1         5  
  0         0  
7728 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7729 0         0 { $e_string .= "Ebig5hkscs::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7730 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7731             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $e_string .= "Ebig5hkscs::filetest qw($1),"; $slash = 'm//'; }
7732 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $e_string .= "Ebig5hkscs::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7733 0         0  
  0         0  
7734 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7735 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7736 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7737 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7738 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  2         10  
7739             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7740 2         6 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         6  
7741 1         3  
  0         0  
7742 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7743 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7744 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7745 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7746 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  2         14  
7747             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7748             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Ebig5hkscs::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7749 2         7  
  0         0  
7750 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7751 0         0 { $e_string .= "Ebig5hkscs::$1($2)"; $slash = 'm//'; }
  0         0  
7752 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Ebig5hkscs::$1($2)"; $slash = 'm//'; }
  0         0  
7753 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= "Ebig5hkscs::$1"; $slash = 'm//'; }
  0         0  
7754 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "Ebig5hkscs::$1(::"."$2)"; $slash = 'm//'; }
  0         0  
7755 0         0 elsif ($string =~ /\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-t $2"; $slash = 'm//'; }
  0         0  
7756             elsif ($string =~ /\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::lstat'; $slash = 'm//'; }
7757             elsif ($string =~ /\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::stat'; $slash = 'm//'; }
7758 0         0  
  0         0  
7759 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
7760 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7761 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7762 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7763 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7764 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7765             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
7766 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7767 0         0  
  0         0  
7768 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7769 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7770 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7771 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7772 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7773             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7774             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7775 0         0  
  0         0  
7776 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
7777 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7778 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
7779             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
7780 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7781 0         0  
  0         0  
7782 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7783 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7784 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::chr'; $slash = 'm//'; }
  0         0  
7785 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7786 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
7787 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ebig5hkscs::glob'; $slash = 'm//'; }
  0         0  
7788 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Ebig5hkscs::lc_'; $slash = 'm//'; }
  0         0  
7789 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Ebig5hkscs::lcfirst_'; $slash = 'm//'; }
  0         0  
7790 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Ebig5hkscs::uc_'; $slash = 'm//'; }
  0         0  
7791 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Ebig5hkscs::ucfirst_'; $slash = 'm//'; }
  0         0  
7792 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Ebig5hkscs::fc_'; $slash = 'm//'; }
  0         0  
7793             elsif ($string =~ /\G \b lstat \b /oxgc) { $e_string .= 'Ebig5hkscs::lstat_'; $slash = 'm//'; }
7794 0         0 elsif ($string =~ /\G \b stat \b /oxgc) { $e_string .= 'Ebig5hkscs::stat_'; $slash = 'm//'; }
  0         0  
7795 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7796 0         0 \b /oxgc) { $e_string .= "Ebig5hkscs::filetest_(qw($1))"; $slash = 'm//'; }
  0         0  
7797             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) \b /oxgc) { $e_string .= "Ebig5hkscs::${1}_"; $slash = 'm//'; }
7798 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
7799 0         0  
  0         0  
7800 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7801 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7802 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Ebig5hkscs::chr_'; $slash = 'm//'; }
  0         0  
7803 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7804 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
7805 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Ebig5hkscs::glob_'; $slash = 'm//'; }
  0         0  
7806 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
7807 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
7808 0         0 elsif ($string =~ /\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Ebig5hkscs::opendir$1*"; $slash = 'm//'; }
  0         0  
7809             elsif ($string =~ /\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Ebig5hkscs::opendir$1*"; $slash = 'm//'; }
7810             elsif ($string =~ /\G \b unlink \b /oxgc) { $e_string .= 'Ebig5hkscs::unlink'; $slash = 'm//'; }
7811              
7812 0         0 # chdir
7813             elsif ($string =~ /\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
7814 0         0 $slash = 'm//';
7815              
7816 0         0 $e_string .= 'Ebig5hkscs::chdir';
7817 0         0  
7818             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7819             $e_string .= $1;
7820             }
7821 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
7822             # end of chdir
7823             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return $e_string; }
7824 0         0  
  0         0  
7825             # chdir scalar value
7826             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= e_string($1); next E_STRING_LOOP; }
7827              
7828 0 0       0 # chdir qq//
  0         0  
  0         0  
7829             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7830 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq# # --> qr # #
7831 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7832 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7833 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7834 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
7835 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
7836 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
7837 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
7838             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq','{','}',$2); next E_STRING_LOOP; } # qq | | --> qr { }
7839 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq * * --> qr * *
7840             }
7841             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7842             }
7843             }
7844              
7845 0 0       0 # chdir q//
  0         0  
  0         0  
7846             elsif ($string =~ /\G \b (q) \b /oxgc) {
7847 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q# # --> qr # #
7848 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7849 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7850 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7851 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
7852 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
7853 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
7854 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
7855             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q','{','}',$2); next E_STRING_LOOP; } # q | | --> qr { }
7856 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q * * --> qr * *
7857             }
7858             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7859             }
7860             }
7861              
7862 0         0 # chdir ''
7863 0         0 elsif ($string =~ /\G (\') /oxgc) {
7864 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7865 0         0 while ($string !~ /\G \z/oxgc) {
7866 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7867 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; }
7868             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_chdir_q('',"'","'",$q_string); next E_STRING_LOOP; }
7869 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7870             }
7871             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7872             }
7873              
7874 0         0 # chdir ""
7875 0         0 elsif ($string =~ /\G (\") /oxgc) {
7876 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
7877 0         0 while ($string !~ /\G \z/oxgc) {
7878 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
7879 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; }
7880             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_chdir('','"','"',$qq_string); next E_STRING_LOOP; }
7881 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
7882             }
7883             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7884             }
7885             }
7886              
7887 0         0 # split
7888             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
7889 0         0 $slash = 'm//';
7890 0         0  
7891 0         0 my $e = '';
7892             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7893             $e .= $1;
7894             }
7895 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7896             # end of split
7897             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Ebig5hkscs::split' . $e; }
7898 0         0  
  0         0  
7899             # split scalar value
7900             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . e_string($1); next E_STRING_LOOP; }
7901 0         0  
  0         0  
7902 0         0 # split literal space
  0         0  
7903 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
7904 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7905 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7906 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7907 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7908 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7909 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
7910 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7911 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7912 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7913 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7914 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7915             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {' '}; next E_STRING_LOOP; }
7916             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Ebig5hkscs::split' . $e . qq {" "}; next E_STRING_LOOP; }
7917              
7918 0 0       0 # split qq//
  0         0  
  0         0  
7919             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7920 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
7921 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7922 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7923 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7924 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
7925 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
7926 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
7927 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
7928             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
7929 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
7930             }
7931             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7932             }
7933             }
7934              
7935 0 0       0 # split qr//
  0         0  
  0         0  
7936             elsif ($string =~ /\G \b (qr) \b /oxgc) {
7937 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
7938 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7939 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7940 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7941 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0         0  
7942 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0         0  
7943 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0         0  
7944 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0         0  
7945 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0         0  
7946             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
7947 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
7948             }
7949             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7950             }
7951             }
7952              
7953 0 0       0 # split q//
  0         0  
  0         0  
7954             elsif ($string =~ /\G \b (q) \b /oxgc) {
7955 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
7956 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7957 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7958 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7959 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
7960 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
7961 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
7962 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
7963             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
7964 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
7965             }
7966             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7967             }
7968             }
7969              
7970 0 0       0 # split m//
  0         0  
  0         0  
7971             elsif ($string =~ /\G \b (m) \b /oxgc) {
7972 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
7973 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7974 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7975 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7976 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0         0  
7977 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0         0  
7978 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0         0  
7979 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0         0  
7980 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0         0  
7981             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
7982 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
7983             }
7984             die __FILE__, ": Search pattern not terminated\n";
7985             }
7986             }
7987              
7988 0         0 # split ''
7989 0         0 elsif ($string =~ /\G (\') /oxgc) {
7990 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7991 0         0 while ($string !~ /\G \z/oxgc) {
7992 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7993 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
7994             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
7995 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7996             }
7997             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7998             }
7999              
8000 0         0 # split ""
8001 0         0 elsif ($string =~ /\G (\") /oxgc) {
8002 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
8003 0         0 while ($string !~ /\G \z/oxgc) {
8004 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
8005 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
8006             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
8007 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
8008             }
8009             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8010             }
8011              
8012 0         0 # split //
8013 0         0 elsif ($string =~ /\G (\/) /oxgc) {
8014 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
8015 0         0 while ($string !~ /\G \z/oxgc) {
8016 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
8017 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
8018             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
8019 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
8020             }
8021             die __FILE__, ": Search pattern not terminated\n";
8022             }
8023             }
8024              
8025 0         0 # qq//
8026 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
8027 0         0 my $ope = $1;
8028             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
8029             $e_string .= e_qq($ope,$1,$3,$2);
8030 0         0 }
8031 0         0 else {
8032 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8033 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8034 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8035 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
8036 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
8037 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
8038             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
8039 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
8040             }
8041             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8042             }
8043             }
8044              
8045 0         0 # qx//
8046 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
8047 0         0 my $ope = $1;
8048             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
8049             $e_string .= e_qq($ope,$1,$3,$2);
8050 0         0 }
8051 0         0 else {
8052 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8053 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8054 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8055 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
8056 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
8057 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
8058 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
8059             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
8060 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
8061             }
8062             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8063             }
8064             }
8065              
8066 0         0 # q//
8067 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
8068 0         0 my $ope = $1;
8069             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
8070             $e_string .= e_q($ope,$1,$3,$2);
8071 0         0 }
8072 0         0 else {
8073 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8074 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8075 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8076 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
8077 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
8078 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
8079             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
8080 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
8081             }
8082             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8083             }
8084             }
8085 0         0  
8086             # ''
8087             elsif ($string =~ /\G (?
8088 44         210  
8089             # ""
8090             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8091 6         70  
8092             # ``
8093             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8094 0         0  
8095             # <<>> (a safer ARGV)
8096             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
8097 0         0  
8098             # <<= <=> <= < operator
8099             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
8100 0         0  
8101             #
8102             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
8103              
8104 0         0 # --- glob
8105             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
8106             $e_string .= 'Ebig5hkscs::glob("' . $1 . '")';
8107             }
8108              
8109 0         0 # << (bit shift) --- not here document
8110 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
8111             $slash = 'm//';
8112             $e_string .= $1;
8113             }
8114              
8115 0         0 # <<~'HEREDOC'
8116 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
8117 0         0 $slash = 'm//';
8118             my $here_quote = $1;
8119             my $delimiter = $2;
8120 0 0       0  
8121 0         0 # get here document
8122 0         0 if ($here_script eq '') {
8123             $here_script = CORE::substr $_, pos $_;
8124 0 0       0 $here_script =~ s/.*?\n//oxm;
8125 0         0 }
8126 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8127 0         0 my $heredoc = $1;
8128 0         0 my $indent = $2;
8129 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8130             push @heredoc, $heredoc . qq{\n$delimiter\n};
8131             push @heredoc_delimiter, qq{\\s*$delimiter};
8132 0         0 }
8133             else {
8134 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8135             }
8136             $e_string .= qq{<<'$delimiter'};
8137             }
8138              
8139 0         0 # <<~\HEREDOC
8140 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
8141 0         0 $slash = 'm//';
8142             my $here_quote = $1;
8143             my $delimiter = $2;
8144 0 0       0  
8145 0         0 # get here document
8146 0         0 if ($here_script eq '') {
8147             $here_script = CORE::substr $_, pos $_;
8148 0 0       0 $here_script =~ s/.*?\n//oxm;
8149 0         0 }
8150 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8151 0         0 my $heredoc = $1;
8152 0         0 my $indent = $2;
8153 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8154             push @heredoc, $heredoc . qq{\n$delimiter\n};
8155             push @heredoc_delimiter, qq{\\s*$delimiter};
8156 0         0 }
8157             else {
8158 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8159             }
8160             $e_string .= qq{<<\\$delimiter};
8161             }
8162              
8163 0         0 # <<~"HEREDOC"
8164 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
8165 0         0 $slash = 'm//';
8166             my $here_quote = $1;
8167             my $delimiter = $2;
8168 0 0       0  
8169 0         0 # get here document
8170 0         0 if ($here_script eq '') {
8171             $here_script = CORE::substr $_, pos $_;
8172 0 0       0 $here_script =~ s/.*?\n//oxm;
8173 0         0 }
8174 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8175 0         0 my $heredoc = $1;
8176 0         0 my $indent = $2;
8177 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8178             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8179             push @heredoc_delimiter, qq{\\s*$delimiter};
8180 0         0 }
8181             else {
8182 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8183             }
8184             $e_string .= qq{<<"$delimiter"};
8185             }
8186              
8187 0         0 # <<~HEREDOC
8188 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
8189 0         0 $slash = 'm//';
8190             my $here_quote = $1;
8191             my $delimiter = $2;
8192 0 0       0  
8193 0         0 # get here document
8194 0         0 if ($here_script eq '') {
8195             $here_script = CORE::substr $_, pos $_;
8196 0 0       0 $here_script =~ s/.*?\n//oxm;
8197 0         0 }
8198 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8199 0         0 my $heredoc = $1;
8200 0         0 my $indent = $2;
8201 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8202             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8203             push @heredoc_delimiter, qq{\\s*$delimiter};
8204 0         0 }
8205             else {
8206 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8207             }
8208             $e_string .= qq{<<$delimiter};
8209             }
8210              
8211 0         0 # <<~`HEREDOC`
8212 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
8213 0         0 $slash = 'm//';
8214             my $here_quote = $1;
8215             my $delimiter = $2;
8216 0 0       0  
8217 0         0 # get here document
8218 0         0 if ($here_script eq '') {
8219             $here_script = CORE::substr $_, pos $_;
8220 0 0       0 $here_script =~ s/.*?\n//oxm;
8221 0         0 }
8222 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8223 0         0 my $heredoc = $1;
8224 0         0 my $indent = $2;
8225 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8226             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8227             push @heredoc_delimiter, qq{\\s*$delimiter};
8228 0         0 }
8229             else {
8230 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8231             }
8232             $e_string .= qq{<<`$delimiter`};
8233             }
8234              
8235 0         0 # <<'HEREDOC'
8236 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
8237 0         0 $slash = 'm//';
8238             my $here_quote = $1;
8239             my $delimiter = $2;
8240 0 0       0  
8241 0         0 # get here document
8242 0         0 if ($here_script eq '') {
8243             $here_script = CORE::substr $_, pos $_;
8244 0 0       0 $here_script =~ s/.*?\n//oxm;
8245 0         0 }
8246 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8247             push @heredoc, $1 . qq{\n$delimiter\n};
8248             push @heredoc_delimiter, $delimiter;
8249 0         0 }
8250             else {
8251 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8252             }
8253             $e_string .= $here_quote;
8254             }
8255              
8256 0         0 # <<\HEREDOC
8257 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
8258 0         0 $slash = 'm//';
8259             my $here_quote = $1;
8260             my $delimiter = $2;
8261 0 0       0  
8262 0         0 # get here document
8263 0         0 if ($here_script eq '') {
8264             $here_script = CORE::substr $_, pos $_;
8265 0 0       0 $here_script =~ s/.*?\n//oxm;
8266 0         0 }
8267 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8268             push @heredoc, $1 . qq{\n$delimiter\n};
8269             push @heredoc_delimiter, $delimiter;
8270 0         0 }
8271             else {
8272 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8273             }
8274             $e_string .= $here_quote;
8275             }
8276              
8277 0         0 # <<"HEREDOC"
8278 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
8279 0         0 $slash = 'm//';
8280             my $here_quote = $1;
8281             my $delimiter = $2;
8282 0 0       0  
8283 0         0 # get here document
8284 0         0 if ($here_script eq '') {
8285             $here_script = CORE::substr $_, pos $_;
8286 0 0       0 $here_script =~ s/.*?\n//oxm;
8287 0         0 }
8288 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8289             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8290             push @heredoc_delimiter, $delimiter;
8291 0         0 }
8292             else {
8293 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8294             }
8295             $e_string .= $here_quote;
8296             }
8297              
8298 0         0 # <
8299 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
8300 0         0 $slash = 'm//';
8301             my $here_quote = $1;
8302             my $delimiter = $2;
8303 0 0       0  
8304 0         0 # get here document
8305 0         0 if ($here_script eq '') {
8306             $here_script = CORE::substr $_, pos $_;
8307 0 0       0 $here_script =~ s/.*?\n//oxm;
8308 0         0 }
8309 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8310             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8311             push @heredoc_delimiter, $delimiter;
8312 0         0 }
8313             else {
8314 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8315             }
8316             $e_string .= $here_quote;
8317             }
8318              
8319 0         0 # <<`HEREDOC`
8320 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
8321 0         0 $slash = 'm//';
8322             my $here_quote = $1;
8323             my $delimiter = $2;
8324 0 0       0  
8325 0         0 # get here document
8326 0         0 if ($here_script eq '') {
8327             $here_script = CORE::substr $_, pos $_;
8328 0 0       0 $here_script =~ s/.*?\n//oxm;
8329 0         0 }
8330 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8331             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8332             push @heredoc_delimiter, $delimiter;
8333 0         0 }
8334             else {
8335 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8336             }
8337             $e_string .= $here_quote;
8338             }
8339              
8340             # any operator before div
8341             elsif ($string =~ /\G (
8342             -- | \+\+ |
8343 0         0 [\)\}\]]
  80         166  
8344              
8345             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
8346              
8347             # yada-yada or triple-dot operator
8348             elsif ($string =~ /\G (
8349 80         459 \.\.\.
  0         0  
8350              
8351             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
8352              
8353             # any operator before m//
8354             elsif ($string =~ /\G ((?>
8355              
8356             !~~ | !~ | != | ! |
8357             %= | % |
8358             &&= | && | &= | &\.= | &\. | & |
8359             -= | -> | - |
8360             :(?>\s*)= |
8361             : |
8362             <<>> |
8363             <<= | <=> | <= | < |
8364             == | => | =~ | = |
8365             >>= | >> | >= | > |
8366             \*\*= | \*\* | \*= | \* |
8367             \+= | \+ |
8368             \.\. | \.= | \. |
8369             \/\/= | \/\/ |
8370             \/= | \/ |
8371             \? |
8372             \\ |
8373             \^= | \^\.= | \^\. | \^ |
8374             \b x= |
8375             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
8376             ~~ | ~\. | ~ |
8377             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
8378             \b(?: print )\b |
8379              
8380 0         0 [,;\(\{\[]
  112         357  
8381              
8382             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
8383 112         1374  
8384             # other any character
8385             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
8386              
8387 353         1619 # system error
8388             else {
8389             die __FILE__, ": Oops, this shouldn't happen!\n";
8390             }
8391 0         0 }
8392              
8393             return $e_string;
8394             }
8395              
8396             #
8397             # character class
8398 79     5434 0 357 #
8399             sub character_class {
8400 5434 100       10805 my($char,$modifier) = @_;
8401 5434 100       9204  
8402 115         250 if ($char eq '.') {
8403             if ($modifier =~ /s/) {
8404             return '${Ebig5hkscs::dot_s}';
8405 23         60 }
8406             else {
8407             return '${Ebig5hkscs::dot}';
8408             }
8409 92         200 }
8410             else {
8411             return Ebig5hkscs::classic_character_class($char);
8412             }
8413             }
8414              
8415             #
8416             # escape capture ($1, $2, $3, ...)
8417             #
8418 5319     637 0 9506 sub e_capture {
8419 637         2753  
8420             return join '', '${Ebig5hkscs::capture(', $_[0], ')}';
8421             return join '', '${', $_[0], '}';
8422             }
8423              
8424             #
8425             # escape transliteration (tr/// or y///)
8426 0     11 0 0 #
8427 11         60 sub e_tr {
8428 11   100     23 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
8429             my $e_tr = '';
8430 11         32 $modifier ||= '';
8431              
8432             $slash = 'div';
8433 11         17  
8434             # quote character class 1
8435             $charclass = q_tr($charclass);
8436 11         24  
8437             # quote character class 2
8438             $charclass2 = q_tr($charclass2);
8439 11 50       24  
8440 11 0       37 # /b /B modifier
8441 0         0 if ($modifier =~ tr/bB//d) {
8442             if ($variable eq '') {
8443             $e_tr = qq{tr$charclass$e$charclass2$modifier};
8444 0         0 }
8445             else {
8446             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
8447             }
8448 0 100       0 }
8449 11         24 else {
8450             if ($variable eq '') {
8451             $e_tr = qq{Ebig5hkscs::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
8452 2         8 }
8453             else {
8454             $e_tr = qq{Ebig5hkscs::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
8455             }
8456             }
8457 9         27  
8458 11         15 # clear tr/// variable
8459             $tr_variable = '';
8460 11         16 $bind_operator = '';
8461              
8462             return $e_tr;
8463             }
8464              
8465             #
8466             # quote for escape transliteration (tr/// or y///)
8467 11     22 0 60 #
8468             sub q_tr {
8469             my($charclass) = @_;
8470 22 50       36  
    0          
    0          
    0          
    0          
    0          
8471 22         50 # quote character class
8472             if ($charclass !~ /'/oxms) {
8473             return e_q('', "'", "'", $charclass); # --> q' '
8474 22         36 }
8475             elsif ($charclass !~ /\//oxms) {
8476             return e_q('q', '/', '/', $charclass); # --> q/ /
8477 0         0 }
8478             elsif ($charclass !~ /\#/oxms) {
8479             return e_q('q', '#', '#', $charclass); # --> q# #
8480 0         0 }
8481             elsif ($charclass !~ /[\<\>]/oxms) {
8482             return e_q('q', '<', '>', $charclass); # --> q< >
8483 0         0 }
8484             elsif ($charclass !~ /[\(\)]/oxms) {
8485             return e_q('q', '(', ')', $charclass); # --> q( )
8486 0         0 }
8487             elsif ($charclass !~ /[\{\}]/oxms) {
8488             return e_q('q', '{', '}', $charclass); # --> q{ }
8489 0         0 }
8490 0 0       0 else {
8491 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8492             if ($charclass !~ /\Q$char\E/xms) {
8493             return e_q('q', $char, $char, $charclass);
8494             }
8495             }
8496 0         0 }
8497              
8498             return e_q('q', '{', '}', $charclass);
8499             }
8500              
8501             #
8502             # escape q string (q//, '')
8503 0     3967 0 0 #
8504             sub e_q {
8505 3967         10583 my($ope,$delimiter,$end_delimiter,$string) = @_;
8506              
8507 3967         6044 $slash = 'div';
8508 3967         25946  
8509             my @char = $string =~ / \G (?>$q_char) /oxmsg;
8510             for (my $i=0; $i <= $#char; $i++) {
8511 3967 100 100     11450  
    100 100        
8512 21301         132184 # escape last octet of multiple-octet
8513             if ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
8514             $char[$i] = $1 . '\\' . $2;
8515 1         7 }
8516             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8517             $char[$i] = $1 . '\\' . $2;
8518 22 100 100     112 }
8519 3967         16361 }
8520             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8521             $char[-1] = $1 . '\\' . $2;
8522 204         660 }
8523 3967         21656  
8524             return join '', $ope, $delimiter, @char, $end_delimiter;
8525             return join '', $ope, $delimiter, $string, $end_delimiter;
8526             }
8527              
8528             #
8529             # escape qq string (qq//, "", qx//, ``)
8530 0     9552 0 0 #
8531             sub e_qq {
8532 9552         23214 my($ope,$delimiter,$end_delimiter,$string) = @_;
8533              
8534 9552         13744 $slash = 'div';
8535 9552         12621  
8536             my $left_e = 0;
8537             my $right_e = 0;
8538 9552         11433  
8539             # split regexp
8540             my @char = $string =~ /\G((?>
8541             [^\x81-\xFE\\\$]|[\x81-\xFE][\x00-\xFF] |
8542             \\x\{ (?>[0-9A-Fa-f]+) \} |
8543             \\o\{ (?>[0-7]+) \} |
8544             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8545             \\ $q_char |
8546             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8547             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8548             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8549             \$ (?>\s* [0-9]+) |
8550             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8551             \$ \$ (?![\w\{]) |
8552             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8553             $q_char
8554 9552         361647 ))/oxmsg;
8555              
8556             for (my $i=0; $i <= $#char; $i++) {
8557 9552 50 66     31466  
    50 33        
    100          
    100          
    50          
8558 310109         1042443 # "\L\u" --> "\u\L"
8559             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8560             @char[$i,$i+1] = @char[$i+1,$i];
8561             }
8562              
8563 0         0 # "\U\l" --> "\l\U"
8564             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8565             @char[$i,$i+1] = @char[$i+1,$i];
8566             }
8567              
8568 0         0 # octal escape sequence
8569             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8570             $char[$i] = Ebig5hkscs::octchr($1);
8571             }
8572              
8573 1         4 # hexadecimal escape sequence
8574             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8575             $char[$i] = Ebig5hkscs::hexchr($1);
8576             }
8577              
8578 1         4 # \N{CHARNAME} --> N{CHARNAME}
8579             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8580             $char[$i] = $1;
8581 0 100       0 }
    100          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
8582              
8583             if (0) {
8584             }
8585              
8586             # escape last octet of multiple-octet
8587 310109         3015620 # my $metachar = qr/[\@\\\|]/oxms; # '|' is for qx//, ``, open(), and system()
8588 0         0 # variable $delimiter and $end_delimiter can be ''
8589             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\@\\\|$delimiter$end_delimiter]) \z/xms) {
8590             $char[$i] = $1 . '\\' . $2;
8591             }
8592              
8593             # \F
8594             #
8595             # P.69 Table 2-6. Translation escapes
8596             # in Chapter 2: Bits and Pieces
8597             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8598             # (and so on)
8599              
8600 1342 50       5007 # \u \l \U \L \F \Q \E
8601 647         1703 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8602             if ($right_e < $left_e) {
8603             $char[$i] = '\\' . $char[$i];
8604             }
8605             }
8606             elsif ($char[$i] eq '\u') {
8607              
8608             # "STRING @{[ LIST EXPR ]} MORE STRING"
8609              
8610             # P.257 Other Tricks You Can Do with Hard References
8611             # in Chapter 8: References
8612             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
8613              
8614             # P.353 Other Tricks You Can Do with Hard References
8615             # in Chapter 8: References
8616             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8617              
8618 0         0 # (and so on)
8619 0         0  
8620             $char[$i] = '@{[Ebig5hkscs::ucfirst qq<';
8621             $left_e++;
8622 0         0 }
8623 0         0 elsif ($char[$i] eq '\l') {
8624             $char[$i] = '@{[Ebig5hkscs::lcfirst qq<';
8625             $left_e++;
8626 0         0 }
8627 0         0 elsif ($char[$i] eq '\U') {
8628             $char[$i] = '@{[Ebig5hkscs::uc qq<';
8629             $left_e++;
8630 0         0 }
8631 6         90 elsif ($char[$i] eq '\L') {
8632             $char[$i] = '@{[Ebig5hkscs::lc qq<';
8633             $left_e++;
8634 6         19 }
8635 9         25 elsif ($char[$i] eq '\F') {
8636             $char[$i] = '@{[Ebig5hkscs::fc qq<';
8637             $left_e++;
8638 9         25 }
8639 0         0 elsif ($char[$i] eq '\Q') {
8640             $char[$i] = '@{[CORE::quotemeta qq<';
8641             $left_e++;
8642 0 50       0 }
8643 12         30 elsif ($char[$i] eq '\E') {
8644 12         19 if ($right_e < $left_e) {
8645             $char[$i] = '>]}';
8646             $right_e++;
8647 12         30 }
8648             else {
8649             $char[$i] = '';
8650             }
8651 0         0 }
8652 0 0       0 elsif ($char[$i] eq '\Q') {
8653 0         0 while (1) {
8654             if (++$i > $#char) {
8655 0 0       0 last;
8656 0         0 }
8657             if ($char[$i] eq '\E') {
8658             last;
8659             }
8660             }
8661             }
8662             elsif ($char[$i] eq '\E') {
8663             }
8664              
8665             # $0 --> $0
8666             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8667             }
8668             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8669             }
8670              
8671             # $$ --> $$
8672             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8673             }
8674              
8675             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8676 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8677             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8678             $char[$i] = e_capture($1);
8679 415         1091 }
8680             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8681             $char[$i] = e_capture($1);
8682             }
8683              
8684 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8685             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8686             $char[$i] = e_capture($1.'->'.$2);
8687             }
8688              
8689 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8690             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8691             $char[$i] = e_capture($1.'->'.$2);
8692             }
8693              
8694 0         0 # $$foo
8695             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8696             $char[$i] = e_capture($1);
8697             }
8698              
8699 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
8700             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8701             $char[$i] = '@{[Ebig5hkscs::PREMATCH()]}';
8702             }
8703              
8704 44         146 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
8705             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8706             $char[$i] = '@{[Ebig5hkscs::MATCH()]}';
8707             }
8708              
8709 45         148 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
8710             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8711             $char[$i] = '@{[Ebig5hkscs::POSTMATCH()]}';
8712             }
8713              
8714             # ${ foo } --> ${ foo }
8715             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8716             }
8717              
8718 33         102 # ${ ... }
8719             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8720             $char[$i] = e_capture($1);
8721             }
8722             }
8723 0 100       0  
8724 9552         20945 # return string
8725             if ($left_e > $right_e) {
8726 3         21 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
8727             }
8728             return join '', $ope, $delimiter, @char, $end_delimiter;
8729             }
8730              
8731             #
8732             # escape qw string (qw//)
8733 9549     34 0 108279 #
8734             sub e_qw {
8735 34         196 my($ope,$delimiter,$end_delimiter,$string) = @_;
8736              
8737             $slash = 'div';
8738 34         107  
  34         366  
8739 621 50       1049 # choice again delimiter
    0          
    0          
    0          
    0          
8740 34         180 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
8741             if (not $octet{$end_delimiter}) {
8742             return join '', $ope, $delimiter, $string, $end_delimiter;
8743 34         240 }
8744             elsif (not $octet{')'}) {
8745             return join '', $ope, '(', $string, ')';
8746 0         0 }
8747             elsif (not $octet{'}'}) {
8748             return join '', $ope, '{', $string, '}';
8749 0         0 }
8750             elsif (not $octet{']'}) {
8751             return join '', $ope, '[', $string, ']';
8752 0         0 }
8753             elsif (not $octet{'>'}) {
8754             return join '', $ope, '<', $string, '>';
8755 0         0 }
8756 0 0       0 else {
8757 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8758             if (not $octet{$char}) {
8759             return join '', $ope, $char, $string, $char;
8760             }
8761             }
8762             }
8763 0         0  
8764 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
8765 0         0 my @string = CORE::split(/\s+/, $string);
8766 0         0 for my $string (@string) {
8767 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
8768 0         0 for my $octet (@octet) {
8769             if ($octet =~ /\A (['\\]) \z/oxms) {
8770             $octet = '\\' . $1;
8771 0         0 }
8772             }
8773 0         0 $string = join '', @octet;
  0         0  
8774             }
8775             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
8776             }
8777              
8778             #
8779             # escape here document (<<"HEREDOC", <
8780 0     108 0 0 #
8781             sub e_heredoc {
8782 108         339 my($string) = @_;
8783              
8784 108         188 $slash = 'm//';
8785              
8786 108         406 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
8787 108         178  
8788             my $left_e = 0;
8789             my $right_e = 0;
8790 108         152  
8791             # split regexp
8792             my @char = $string =~ /\G((?>
8793             [^\x81-\xFE\\\$]|[\x81-\xFE][\x00-\xFF] |
8794             \\x\{ (?>[0-9A-Fa-f]+) \} |
8795             \\o\{ (?>[0-7]+) \} |
8796             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8797             \\ $q_char |
8798             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8799             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8800             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8801             \$ (?>\s* [0-9]+) |
8802             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8803             \$ \$ (?![\w\{]) |
8804             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8805             $q_char
8806 108         10784 ))/oxmsg;
8807              
8808             for (my $i=0; $i <= $#char; $i++) {
8809 108 50 66     511  
    50 33        
    100          
    100          
    50          
8810 3355         10422 # "\L\u" --> "\u\L"
8811             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8812             @char[$i,$i+1] = @char[$i+1,$i];
8813             }
8814              
8815 0         0 # "\U\l" --> "\l\U"
8816             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8817             @char[$i,$i+1] = @char[$i+1,$i];
8818             }
8819              
8820 0         0 # octal escape sequence
8821             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8822             $char[$i] = Ebig5hkscs::octchr($1);
8823             }
8824              
8825 1         4 # hexadecimal escape sequence
8826             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8827             $char[$i] = Ebig5hkscs::hexchr($1);
8828             }
8829              
8830 1         3 # \N{CHARNAME} --> N{CHARNAME}
8831             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8832             $char[$i] = $1;
8833 0 100       0 }
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
8834              
8835             if (0) {
8836             }
8837 3355         29613  
8838 0         0 # escape character
8839             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
8840             $char[$i] = $1 . '\\' . $2;
8841             }
8842              
8843 57 50       223 # \u \l \U \L \F \Q \E
8844 72         141 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8845             if ($right_e < $left_e) {
8846             $char[$i] = '\\' . $char[$i];
8847             }
8848 0         0 }
8849 0         0 elsif ($char[$i] eq '\u') {
8850             $char[$i] = '@{[Ebig5hkscs::ucfirst qq<';
8851             $left_e++;
8852 0         0 }
8853 0         0 elsif ($char[$i] eq '\l') {
8854             $char[$i] = '@{[Ebig5hkscs::lcfirst qq<';
8855             $left_e++;
8856 0         0 }
8857 0         0 elsif ($char[$i] eq '\U') {
8858             $char[$i] = '@{[Ebig5hkscs::uc qq<';
8859             $left_e++;
8860 0         0 }
8861 6         10 elsif ($char[$i] eq '\L') {
8862             $char[$i] = '@{[Ebig5hkscs::lc qq<';
8863             $left_e++;
8864 6         9 }
8865 0         0 elsif ($char[$i] eq '\F') {
8866             $char[$i] = '@{[Ebig5hkscs::fc qq<';
8867             $left_e++;
8868 0         0 }
8869 0         0 elsif ($char[$i] eq '\Q') {
8870             $char[$i] = '@{[CORE::quotemeta qq<';
8871             $left_e++;
8872 0 50       0 }
8873 3         7 elsif ($char[$i] eq '\E') {
8874 3         8 if ($right_e < $left_e) {
8875             $char[$i] = '>]}';
8876             $right_e++;
8877 3         5 }
8878             else {
8879             $char[$i] = '';
8880             }
8881 0         0 }
8882 0 0       0 elsif ($char[$i] eq '\Q') {
8883 0         0 while (1) {
8884             if (++$i > $#char) {
8885 0 0       0 last;
8886 0         0 }
8887             if ($char[$i] eq '\E') {
8888             last;
8889             }
8890             }
8891             }
8892             elsif ($char[$i] eq '\E') {
8893             }
8894              
8895             # $0 --> $0
8896             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8897             }
8898             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8899             }
8900              
8901             # $$ --> $$
8902             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8903             }
8904              
8905             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8906 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8907             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8908             $char[$i] = e_capture($1);
8909 0         0 }
8910             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8911             $char[$i] = e_capture($1);
8912             }
8913              
8914 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8915             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8916             $char[$i] = e_capture($1.'->'.$2);
8917             }
8918              
8919 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8920             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8921             $char[$i] = e_capture($1.'->'.$2);
8922             }
8923              
8924 0         0 # $$foo
8925             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8926             $char[$i] = e_capture($1);
8927             }
8928              
8929 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
8930             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8931             $char[$i] = '@{[Ebig5hkscs::PREMATCH()]}';
8932             }
8933              
8934 8         47 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
8935             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8936             $char[$i] = '@{[Ebig5hkscs::MATCH()]}';
8937             }
8938              
8939 8         49 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
8940             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8941             $char[$i] = '@{[Ebig5hkscs::POSTMATCH()]}';
8942             }
8943              
8944             # ${ foo } --> ${ foo }
8945             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8946             }
8947              
8948 6         35 # ${ ... }
8949             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8950             $char[$i] = e_capture($1);
8951             }
8952             }
8953 0 100       0  
8954 108         263 # return string
8955             if ($left_e > $right_e) {
8956 3         27 return join '', @char, '>]}' x ($left_e - $right_e);
8957             }
8958             return join '', @char;
8959             }
8960              
8961             #
8962             # escape regexp (m//, qr//)
8963 105     1835 0 812 #
8964 1835   100     7885 sub e_qr {
8965             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
8966 1835         6882 $modifier ||= '';
8967 1835 50       3576  
8968 1835         4672 $modifier =~ tr/p//d;
8969 0         0 if ($modifier =~ /([adlu])/oxms) {
8970 0 0       0 my $line = 0;
8971 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
8972 0         0 if ($filename ne __FILE__) {
8973             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
8974             last;
8975 0         0 }
8976             }
8977             die qq{Unsupported modifier "$1" used at line $line.\n};
8978 0         0 }
8979              
8980             $slash = 'div';
8981 1835 100       3391  
    100          
8982 1835         5517 # literal null string pattern
8983 8         11 if ($string eq '') {
8984 8         9 $modifier =~ tr/bB//d;
8985             $modifier =~ tr/i//d;
8986             return join '', $ope, $delimiter, $end_delimiter, $modifier;
8987             }
8988              
8989             # /b /B modifier
8990             elsif ($modifier =~ tr/bB//d) {
8991 8 50       38  
8992 240         559 # choice again delimiter
8993 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
8994 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
8995 0         0 my %octet = map {$_ => 1} @char;
8996 0         0 if (not $octet{')'}) {
8997             $delimiter = '(';
8998             $end_delimiter = ')';
8999 0         0 }
9000 0         0 elsif (not $octet{'}'}) {
9001             $delimiter = '{';
9002             $end_delimiter = '}';
9003 0         0 }
9004 0         0 elsif (not $octet{']'}) {
9005             $delimiter = '[';
9006             $end_delimiter = ']';
9007 0         0 }
9008 0         0 elsif (not $octet{'>'}) {
9009             $delimiter = '<';
9010             $end_delimiter = '>';
9011 0         0 }
9012 0 0       0 else {
9013 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9014 0         0 if (not $octet{$char}) {
9015 0         0 $delimiter = $char;
9016             $end_delimiter = $char;
9017             last;
9018             }
9019             }
9020             }
9021 0 100 100     0 }
9022 240         1093  
9023             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9024             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
9025 90         1706 }
9026             else {
9027             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9028             }
9029 150 100       855 }
9030 1587         4778  
9031             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9032             my $metachar = qr/[\@\\|[\]{^]/oxms;
9033 1587         5613  
9034             # split regexp
9035             my @char = $string =~ /\G((?>
9036             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
9037             \\x (?>[0-9A-Fa-f]{1,2}) |
9038             \\ (?>[0-7]{2,3}) |
9039             \\c [\x40-\x5F] |
9040             \\x\{ (?>[0-9A-Fa-f]+) \} |
9041             \\o\{ (?>[0-7]+) \} |
9042             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9043             \\ $q_char |
9044             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9045             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9046             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9047             [\$\@] $qq_variable |
9048             \$ (?>\s* [0-9]+) |
9049             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9050             \$ \$ (?![\w\{]) |
9051             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9052             \[\^ |
9053             \[\: (?>[a-z]+) :\] |
9054             \[\:\^ (?>[a-z]+) :\] |
9055             \(\? |
9056             $q_char
9057             ))/oxmsg;
9058 1587 50       136917  
9059 1587         7441 # choice again delimiter
  0         0  
9060 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9061 0         0 my %octet = map {$_ => 1} @char;
9062 0         0 if (not $octet{')'}) {
9063             $delimiter = '(';
9064             $end_delimiter = ')';
9065 0         0 }
9066 0         0 elsif (not $octet{'}'}) {
9067             $delimiter = '{';
9068             $end_delimiter = '}';
9069 0         0 }
9070 0         0 elsif (not $octet{']'}) {
9071             $delimiter = '[';
9072             $end_delimiter = ']';
9073 0         0 }
9074 0         0 elsif (not $octet{'>'}) {
9075             $delimiter = '<';
9076             $end_delimiter = '>';
9077 0         0 }
9078 0 0       0 else {
9079 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9080 0         0 if (not $octet{$char}) {
9081 0         0 $delimiter = $char;
9082             $end_delimiter = $char;
9083             last;
9084             }
9085             }
9086             }
9087 0         0 }
9088 1587         2563  
9089 1587         3453 my $left_e = 0;
9090             my $right_e = 0;
9091             for (my $i=0; $i <= $#char; $i++) {
9092 1587 50 66     4165  
    50 66        
    100          
    100          
    100          
    100          
9093 5514         28389 # "\L\u" --> "\u\L"
9094             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9095             @char[$i,$i+1] = @char[$i+1,$i];
9096             }
9097              
9098 0         0 # "\U\l" --> "\l\U"
9099             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9100             @char[$i,$i+1] = @char[$i+1,$i];
9101             }
9102              
9103 0         0 # octal escape sequence
9104             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9105             $char[$i] = Ebig5hkscs::octchr($1);
9106             }
9107              
9108 1         4 # hexadecimal escape sequence
9109             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9110             $char[$i] = Ebig5hkscs::hexchr($1);
9111             }
9112              
9113             # \b{...} --> b\{...}
9114             # \B{...} --> B\{...}
9115             # \N{CHARNAME} --> N\{CHARNAME}
9116             # \p{PROPERTY} --> p\{PROPERTY}
9117 1         4 # \P{PROPERTY} --> P\{PROPERTY}
9118             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9119             $char[$i] = $1 . '\\' . $2;
9120             }
9121              
9122 6         19 # \p, \P, \X --> p, P, X
9123             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9124             $char[$i] = $1;
9125 4 100 100     11 }
    100 100        
    100 100        
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
9126              
9127             if (0) {
9128             }
9129 5514         38744  
9130 0         0 # escape last octet of multiple-octet
9131             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9132             $char[$i] = $1 . '\\' . $2;
9133             }
9134              
9135 77 50 33     329 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
9136 6         166 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9137             if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
9138             $char[$i] .= join '', splice @char, $i+1, 3;
9139 0         0 }
9140             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
9141             $char[$i] .= join '', splice @char, $i+1, 2;
9142 0         0 }
9143             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
9144             $char[$i] .= join '', splice @char, $i+1, 1;
9145             }
9146             }
9147              
9148 0         0 # open character class [...]
9149             elsif ($char[$i] eq '[') {
9150             my $left = $i;
9151              
9152             # [] make die "Unmatched [] in regexp ...\n"
9153 586 100       981 # (and so on)
9154 586         1531  
9155             if ($char[$i+1] eq ']') {
9156             $i++;
9157 3         6 }
9158 586 50       781  
9159 2583         4085 while (1) {
9160             if (++$i > $#char) {
9161 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9162 2583         4284 }
9163             if ($char[$i] eq ']') {
9164             my $right = $i;
9165 586 100       783  
9166 586         3478 # [...]
  90         230  
9167             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9168             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);
9169 270         516 }
9170             else {
9171             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
9172 496         1929 }
9173 586         1145  
9174             $i = $left;
9175             last;
9176             }
9177             }
9178             }
9179              
9180 586         1854 # open character class [^...]
9181             elsif ($char[$i] eq '[^') {
9182             my $left = $i;
9183              
9184             # [^] make die "Unmatched [] in regexp ...\n"
9185 328 100       581 # (and so on)
9186 328         776  
9187             if ($char[$i+1] eq ']') {
9188             $i++;
9189 5         9 }
9190 328 50       427  
9191 1447         2254 while (1) {
9192             if (++$i > $#char) {
9193 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9194 1447         2441 }
9195             if ($char[$i] eq ']') {
9196             my $right = $i;
9197 328 100       408  
9198 328         1709 # [^...]
  90         239  
9199             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9200             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);
9201 270         477 }
9202             else {
9203             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9204 238         847 }
9205 328         672  
9206             $i = $left;
9207             last;
9208             }
9209             }
9210             }
9211              
9212 328         986 # rewrite character class or escape character
9213             elsif (my $char = character_class($char[$i],$modifier)) {
9214             $char[$i] = $char;
9215             }
9216              
9217 215 50       561 # /i modifier
9218 238         483 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
9219             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
9220             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
9221 238         508 }
9222             else {
9223             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
9224             }
9225             }
9226              
9227 0 50       0 # \u \l \U \L \F \Q \E
9228 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9229             if ($right_e < $left_e) {
9230             $char[$i] = '\\' . $char[$i];
9231             }
9232 0         0 }
9233 0         0 elsif ($char[$i] eq '\u') {
9234             $char[$i] = '@{[Ebig5hkscs::ucfirst qq<';
9235             $left_e++;
9236 0         0 }
9237 0         0 elsif ($char[$i] eq '\l') {
9238             $char[$i] = '@{[Ebig5hkscs::lcfirst qq<';
9239             $left_e++;
9240 0         0 }
9241 1         4 elsif ($char[$i] eq '\U') {
9242             $char[$i] = '@{[Ebig5hkscs::uc qq<';
9243             $left_e++;
9244 1         4 }
9245 1         3 elsif ($char[$i] eq '\L') {
9246             $char[$i] = '@{[Ebig5hkscs::lc qq<';
9247             $left_e++;
9248 1         3 }
9249 9         18 elsif ($char[$i] eq '\F') {
9250             $char[$i] = '@{[Ebig5hkscs::fc qq<';
9251             $left_e++;
9252 9         27 }
9253 22         99 elsif ($char[$i] eq '\Q') {
9254             $char[$i] = '@{[CORE::quotemeta qq<';
9255             $left_e++;
9256 22 50       60 }
9257 33         173 elsif ($char[$i] eq '\E') {
9258 33         56 if ($right_e < $left_e) {
9259             $char[$i] = '>]}';
9260             $right_e++;
9261 33         96 }
9262             else {
9263             $char[$i] = '';
9264             }
9265 0         0 }
9266 0 0       0 elsif ($char[$i] eq '\Q') {
9267 0         0 while (1) {
9268             if (++$i > $#char) {
9269 0 0       0 last;
9270 0         0 }
9271             if ($char[$i] eq '\E') {
9272             last;
9273             }
9274             }
9275             }
9276             elsif ($char[$i] eq '\E') {
9277             }
9278              
9279 0 0       0 # $0 --> $0
9280 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9281             if ($ignorecase) {
9282             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9283             }
9284 0 0       0 }
9285 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9286             if ($ignorecase) {
9287             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9288             }
9289             }
9290              
9291             # $$ --> $$
9292             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9293             }
9294              
9295             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9296 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9297 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9298 0         0 $char[$i] = e_capture($1);
9299             if ($ignorecase) {
9300             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9301             }
9302 0         0 }
9303 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9304 0         0 $char[$i] = e_capture($1);
9305             if ($ignorecase) {
9306             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9307             }
9308             }
9309              
9310 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
9311 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
9312 0         0 $char[$i] = e_capture($1.'->'.$2);
9313             if ($ignorecase) {
9314             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9315             }
9316             }
9317              
9318 0         0 # $$foo{ ... } --> $ $foo->{ ... }
9319 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
9320 0         0 $char[$i] = e_capture($1.'->'.$2);
9321             if ($ignorecase) {
9322             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9323             }
9324             }
9325              
9326 0         0 # $$foo
9327 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
9328 0         0 $char[$i] = e_capture($1);
9329             if ($ignorecase) {
9330             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9331             }
9332             }
9333              
9334 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
9335 8         23 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
9336             if ($ignorecase) {
9337             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::PREMATCH())]}';
9338 0         0 }
9339             else {
9340             $char[$i] = '@{[Ebig5hkscs::PREMATCH()]}';
9341             }
9342             }
9343              
9344 8 50       27 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
9345 8         24 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
9346             if ($ignorecase) {
9347             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::MATCH())]}';
9348 0         0 }
9349             else {
9350             $char[$i] = '@{[Ebig5hkscs::MATCH()]}';
9351             }
9352             }
9353              
9354 8 50       25 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
9355 6         17 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
9356             if ($ignorecase) {
9357             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::POSTMATCH())]}';
9358 0         0 }
9359             else {
9360             $char[$i] = '@{[Ebig5hkscs::POSTMATCH()]}';
9361             }
9362             }
9363              
9364 6 0       20 # ${ foo }
9365 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
9366             if ($ignorecase) {
9367             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9368             }
9369             }
9370              
9371 0         0 # ${ ... }
9372 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
9373 0         0 $char[$i] = e_capture($1);
9374             if ($ignorecase) {
9375             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9376             }
9377             }
9378              
9379 0         0 # $scalar or @array
9380 31 100       146 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
9381 31         144 $char[$i] = e_string($char[$i]);
9382             if ($ignorecase) {
9383             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9384             }
9385             }
9386              
9387 4 100 66     19 # quote character before ? + * {
    50          
9388             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9389             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
9390 188         1421 }
9391 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9392 0         0 my $char = $char[$i-1];
9393             if ($char[$i] eq '{') {
9394             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
9395 0         0 }
9396             else {
9397             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
9398             }
9399 0         0 }
9400             else {
9401             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9402             }
9403             }
9404             }
9405 187         876  
9406 1587 50       14522 # make regexp string
9407 1587 0 0     3521 $modifier =~ tr/i//d;
9408 0         0 if ($left_e > $right_e) {
9409             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9410             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
9411 0         0 }
9412             else {
9413             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
9414 0 100 100     0 }
9415 1587         8787 }
9416             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9417             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
9418 94         937 }
9419             else {
9420             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9421             }
9422             }
9423              
9424             #
9425             # double quote stuff
9426 1493     540 0 13816 #
9427             sub qq_stuff {
9428             my($delimiter,$end_delimiter,$stuff) = @_;
9429 540 100       1101  
9430 540         1408 # scalar variable or array variable
9431             if ($stuff =~ /\A [\$\@] /oxms) {
9432             return $stuff;
9433             }
9434 300         1204  
  240         738  
9435 280         845 # quote by delimiter
9436 240 50       653 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
9437 240 50       461 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9438 240 50       436 next if $char eq $delimiter;
9439 240         509 next if $char eq $end_delimiter;
9440             if (not $octet{$char}) {
9441             return join '', 'qq', $char, $stuff, $char;
9442 240         1098 }
9443             }
9444             return join '', 'qq', '<', $stuff, '>';
9445             }
9446              
9447             #
9448             # escape regexp (m'', qr'', and m''b, qr''b)
9449 0     163 0 0 #
9450 163   100     803 sub e_qr_q {
9451             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9452 163         527 $modifier ||= '';
9453 163 50       447  
9454 163         525 $modifier =~ tr/p//d;
9455 0         0 if ($modifier =~ /([adlu])/oxms) {
9456 0 0       0 my $line = 0;
9457 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9458 0         0 if ($filename ne __FILE__) {
9459             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9460             last;
9461 0         0 }
9462             }
9463             die qq{Unsupported modifier "$1" used at line $line.\n};
9464 0         0 }
9465              
9466             $slash = 'div';
9467 163 100       247  
    100          
9468 163         445 # literal null string pattern
9469 8         10 if ($string eq '') {
9470 8         10 $modifier =~ tr/bB//d;
9471             $modifier =~ tr/i//d;
9472             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9473             }
9474              
9475 8         41 # with /b /B modifier
9476             elsif ($modifier =~ tr/bB//d) {
9477             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
9478             }
9479              
9480 89         252 # without /b /B modifier
9481             else {
9482             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
9483             }
9484             }
9485              
9486             #
9487             # escape regexp (m'', qr'')
9488 66     66 0 173 #
9489             sub e_qr_qt {
9490 66 100       195 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9491              
9492             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9493 66         186  
9494             # split regexp
9495             my @char = $string =~ /\G((?>
9496             [^\x81-\xFE\\\[\$\@\/] |
9497             [\x81-\xFE][\x00-\xFF] |
9498             \[\^ |
9499             \[\: (?>[a-z]+) \:\] |
9500             \[\:\^ (?>[a-z]+) \:\] |
9501             [\$\@\/] |
9502             \\ (?:$q_char) |
9503             (?:$q_char)
9504             ))/oxmsg;
9505 66         742  
9506 66 100 100     247 # unescape character
    50 100        
    50 66        
    50          
    50          
    100          
    50          
9507             for (my $i=0; $i <= $#char; $i++) {
9508             if (0) {
9509             }
9510 79         1270  
9511 0         0 # escape last octet of multiple-octet
9512             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9513             $char[$i] = $1 . '\\' . $2;
9514             }
9515              
9516 2         16 # open character class [...]
9517 0 0       0 elsif ($char[$i] eq '[') {
9518 0         0 my $left = $i;
9519             if ($char[$i+1] eq ']') {
9520 0         0 $i++;
9521 0 0       0 }
9522 0         0 while (1) {
9523             if (++$i > $#char) {
9524 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9525 0         0 }
9526             if ($char[$i] eq ']') {
9527             my $right = $i;
9528 0         0  
9529             # [...]
9530 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
9531 0         0  
9532             $i = $left;
9533             last;
9534             }
9535             }
9536             }
9537              
9538 0         0 # open character class [^...]
9539 0 0       0 elsif ($char[$i] eq '[^') {
9540 0         0 my $left = $i;
9541             if ($char[$i+1] eq ']') {
9542 0         0 $i++;
9543 0 0       0 }
9544 0         0 while (1) {
9545             if (++$i > $#char) {
9546 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9547 0         0 }
9548             if ($char[$i] eq ']') {
9549             my $right = $i;
9550 0         0  
9551             # [^...]
9552 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9553 0         0  
9554             $i = $left;
9555             last;
9556             }
9557             }
9558             }
9559              
9560 0         0 # escape $ @ / and \
9561             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9562             $char[$i] = '\\' . $char[$i];
9563             }
9564              
9565 0         0 # rewrite character class or escape character
9566             elsif (my $char = character_class($char[$i],$modifier)) {
9567             $char[$i] = $char;
9568             }
9569              
9570 0 50       0 # /i modifier
9571 16         49 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
9572             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
9573             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
9574 16         45 }
9575             else {
9576             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
9577             }
9578             }
9579              
9580 0 0       0 # quote character before ? + * {
9581             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9582             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
9583 0         0 }
9584             else {
9585             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9586             }
9587             }
9588 0         0 }
9589 66         139  
9590             $delimiter = '/';
9591 66         93 $end_delimiter = '/';
9592 66         96  
9593             $modifier =~ tr/i//d;
9594             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9595             }
9596              
9597             #
9598             # escape regexp (m''b, qr''b)
9599 66     89 0 532 #
9600             sub e_qr_qb {
9601             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9602 89         256  
9603             # split regexp
9604             my @char = $string =~ /\G ((?>[^\\]|\\\\|[\x00-\xFF])) /oxmsg;
9605 89         383  
9606 89 50       278 # unescape character
    50          
9607             for (my $i=0; $i <= $#char; $i++) {
9608             if (0) {
9609             }
9610 199         685  
9611             # remain \\
9612             elsif ($char[$i] eq '\\\\') {
9613             }
9614              
9615 0         0 # escape $ @ / and \
9616             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9617             $char[$i] = '\\' . $char[$i];
9618             }
9619 0         0 }
9620 89         152  
9621 89         127 $delimiter = '/';
9622             $end_delimiter = '/';
9623             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9624             }
9625              
9626             #
9627             # escape regexp (s/here//)
9628 89     194 0 541 #
9629 194   100     585 sub e_s1 {
9630             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9631 194         848 $modifier ||= '';
9632 194 50       309  
9633 194         688 $modifier =~ tr/p//d;
9634 0         0 if ($modifier =~ /([adlu])/oxms) {
9635 0 0       0 my $line = 0;
9636 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9637 0         0 if ($filename ne __FILE__) {
9638             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9639             last;
9640 0         0 }
9641             }
9642             die qq{Unsupported modifier "$1" used at line $line.\n};
9643 0         0 }
9644              
9645             $slash = 'div';
9646 194 100       369  
    100          
9647 194         729 # literal null string pattern
9648 8         11 if ($string eq '') {
9649 8         8 $modifier =~ tr/bB//d;
9650             $modifier =~ tr/i//d;
9651             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9652             }
9653              
9654             # /b /B modifier
9655             elsif ($modifier =~ tr/bB//d) {
9656 8 50       58  
9657 44         113 # choice again delimiter
9658 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
9659 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
9660 0         0 my %octet = map {$_ => 1} @char;
9661 0         0 if (not $octet{')'}) {
9662             $delimiter = '(';
9663             $end_delimiter = ')';
9664 0         0 }
9665 0         0 elsif (not $octet{'}'}) {
9666             $delimiter = '{';
9667             $end_delimiter = '}';
9668 0         0 }
9669 0         0 elsif (not $octet{']'}) {
9670             $delimiter = '[';
9671             $end_delimiter = ']';
9672 0         0 }
9673 0         0 elsif (not $octet{'>'}) {
9674             $delimiter = '<';
9675             $end_delimiter = '>';
9676 0         0 }
9677 0 0       0 else {
9678 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9679 0         0 if (not $octet{$char}) {
9680 0         0 $delimiter = $char;
9681             $end_delimiter = $char;
9682             last;
9683             }
9684             }
9685             }
9686 0         0 }
9687 44         63  
9688 44         59 my $prematch = '';
9689             $prematch = q{(\G[\x00-\xFF]*?)};
9690             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9691 44 100       374 }
9692 142         624  
9693             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9694             my $metachar = qr/[\@\\|[\]{^]/oxms;
9695 142         604  
9696             # split regexp
9697             my @char = $string =~ /\G((?>
9698             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
9699             \\ (?>[1-9][0-9]*) |
9700             \\g (?>\s*) (?>[1-9][0-9]*) |
9701             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9702             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9703             \\x (?>[0-9A-Fa-f]{1,2}) |
9704             \\ (?>[0-7]{2,3}) |
9705             \\c [\x40-\x5F] |
9706             \\x\{ (?>[0-9A-Fa-f]+) \} |
9707             \\o\{ (?>[0-7]+) \} |
9708             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9709             \\ $q_char |
9710             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9711             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9712             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9713             [\$\@] $qq_variable |
9714             \$ (?>\s* [0-9]+) |
9715             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9716             \$ \$ (?![\w\{]) |
9717             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9718             \[\^ |
9719             \[\: (?>[a-z]+) :\] |
9720             \[\:\^ (?>[a-z]+) :\] |
9721             \(\? |
9722             $q_char
9723             ))/oxmsg;
9724 142 50       62571  
9725 142         1182 # choice again delimiter
  0         0  
9726 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9727 0         0 my %octet = map {$_ => 1} @char;
9728 0         0 if (not $octet{')'}) {
9729             $delimiter = '(';
9730             $end_delimiter = ')';
9731 0         0 }
9732 0         0 elsif (not $octet{'}'}) {
9733             $delimiter = '{';
9734             $end_delimiter = '}';
9735 0         0 }
9736 0         0 elsif (not $octet{']'}) {
9737             $delimiter = '[';
9738             $end_delimiter = ']';
9739 0         0 }
9740 0         0 elsif (not $octet{'>'}) {
9741             $delimiter = '<';
9742             $end_delimiter = '>';
9743 0         0 }
9744 0 0       0 else {
9745 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9746 0         0 if (not $octet{$char}) {
9747 0         0 $delimiter = $char;
9748             $end_delimiter = $char;
9749             last;
9750             }
9751             }
9752             }
9753             }
9754 0         0  
  142         310  
9755             # count '('
9756 476         951 my $parens = grep { $_ eq '(' } @char;
9757 142         246  
9758 142         254 my $left_e = 0;
9759             my $right_e = 0;
9760             for (my $i=0; $i <= $#char; $i++) {
9761 142 50 33     465  
    50 33        
    100          
    100          
    50          
    50          
9762 397         2806 # "\L\u" --> "\u\L"
9763             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9764             @char[$i,$i+1] = @char[$i+1,$i];
9765             }
9766              
9767 0         0 # "\U\l" --> "\l\U"
9768             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9769             @char[$i,$i+1] = @char[$i+1,$i];
9770             }
9771              
9772 0         0 # octal escape sequence
9773             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9774             $char[$i] = Ebig5hkscs::octchr($1);
9775             }
9776              
9777 1         4 # hexadecimal escape sequence
9778             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9779             $char[$i] = Ebig5hkscs::hexchr($1);
9780             }
9781              
9782             # \b{...} --> b\{...}
9783             # \B{...} --> B\{...}
9784             # \N{CHARNAME} --> N\{CHARNAME}
9785             # \p{PROPERTY} --> p\{PROPERTY}
9786 1         4 # \P{PROPERTY} --> P\{PROPERTY}
9787             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9788             $char[$i] = $1 . '\\' . $2;
9789             }
9790              
9791 0         0 # \p, \P, \X --> p, P, X
9792             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9793             $char[$i] = $1;
9794 0 100 100     0 }
    50 100        
    100 100        
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
9795              
9796             if (0) {
9797             }
9798 397         4682  
9799 0         0 # escape last octet of multiple-octet
9800             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9801             $char[$i] = $1 . '\\' . $2;
9802             }
9803              
9804 23 0 0     185 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
9805 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9806             if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
9807             $char[$i] .= join '', splice @char, $i+1, 3;
9808 0         0 }
9809             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
9810             $char[$i] .= join '', splice @char, $i+1, 2;
9811 0         0 }
9812             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
9813             $char[$i] .= join '', splice @char, $i+1, 1;
9814             }
9815             }
9816              
9817 0         0 # open character class [...]
9818 20 50       51 elsif ($char[$i] eq '[') {
9819 20         79 my $left = $i;
9820             if ($char[$i+1] eq ']') {
9821 0         0 $i++;
9822 20 50       41 }
9823 79         132 while (1) {
9824             if (++$i > $#char) {
9825 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9826 79         233 }
9827             if ($char[$i] eq ']') {
9828             my $right = $i;
9829 20 50       40  
9830 20         162 # [...]
  0         0  
9831             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9832             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);
9833 0         0 }
9834             else {
9835             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
9836 20         171 }
9837 20         37  
9838             $i = $left;
9839             last;
9840             }
9841             }
9842             }
9843              
9844 20         70 # open character class [^...]
9845 0 0       0 elsif ($char[$i] eq '[^') {
9846 0         0 my $left = $i;
9847             if ($char[$i+1] eq ']') {
9848 0         0 $i++;
9849 0 0       0 }
9850 0         0 while (1) {
9851             if (++$i > $#char) {
9852 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9853 0         0 }
9854             if ($char[$i] eq ']') {
9855             my $right = $i;
9856 0 0       0  
9857 0         0 # [^...]
  0         0  
9858             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9859             splice @char, $left, $right-$left+1, sprintf(q{@{[Ebig5hkscs::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9860 0         0 }
9861             else {
9862             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9863 0         0 }
9864 0         0  
9865             $i = $left;
9866             last;
9867             }
9868             }
9869             }
9870              
9871 0         0 # rewrite character class or escape character
9872             elsif (my $char = character_class($char[$i],$modifier)) {
9873             $char[$i] = $char;
9874             }
9875              
9876 11 50       28 # /i modifier
9877 11         31 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
9878             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
9879             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
9880 11         24 }
9881             else {
9882             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
9883             }
9884             }
9885              
9886 0 50       0 # \u \l \U \L \F \Q \E
9887 8         32 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9888             if ($right_e < $left_e) {
9889             $char[$i] = '\\' . $char[$i];
9890             }
9891 0         0 }
9892 0         0 elsif ($char[$i] eq '\u') {
9893             $char[$i] = '@{[Ebig5hkscs::ucfirst qq<';
9894             $left_e++;
9895 0         0 }
9896 0         0 elsif ($char[$i] eq '\l') {
9897             $char[$i] = '@{[Ebig5hkscs::lcfirst qq<';
9898             $left_e++;
9899 0         0 }
9900 0         0 elsif ($char[$i] eq '\U') {
9901             $char[$i] = '@{[Ebig5hkscs::uc qq<';
9902             $left_e++;
9903 0         0 }
9904 0         0 elsif ($char[$i] eq '\L') {
9905             $char[$i] = '@{[Ebig5hkscs::lc qq<';
9906             $left_e++;
9907 0         0 }
9908 0         0 elsif ($char[$i] eq '\F') {
9909             $char[$i] = '@{[Ebig5hkscs::fc qq<';
9910             $left_e++;
9911 0         0 }
9912 7         16 elsif ($char[$i] eq '\Q') {
9913             $char[$i] = '@{[CORE::quotemeta qq<';
9914             $left_e++;
9915 7 50       17 }
9916 7         20 elsif ($char[$i] eq '\E') {
9917 7         13 if ($right_e < $left_e) {
9918             $char[$i] = '>]}';
9919             $right_e++;
9920 7         17 }
9921             else {
9922             $char[$i] = '';
9923             }
9924 0         0 }
9925 0 0       0 elsif ($char[$i] eq '\Q') {
9926 0         0 while (1) {
9927             if (++$i > $#char) {
9928 0 0       0 last;
9929 0         0 }
9930             if ($char[$i] eq '\E') {
9931             last;
9932             }
9933             }
9934             }
9935             elsif ($char[$i] eq '\E') {
9936             }
9937              
9938             # \0 --> \0
9939             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
9940             }
9941              
9942             # \g{N}, \g{-N}
9943              
9944             # P.108 Using Simple Patterns
9945             # in Chapter 7: In the World of Regular Expressions
9946             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
9947              
9948             # P.221 Capturing
9949             # in Chapter 5: Pattern Matching
9950             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
9951              
9952             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
9953             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9954             }
9955              
9956 0 0       0 # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
9957 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9958             if ($1 <= $parens) {
9959             $char[$i] = '\\g{' . ($1 + 1) . '}';
9960             }
9961             }
9962              
9963 0 0       0 # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
9964 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9965             if ($1 <= $parens) {
9966             $char[$i] = '\\g' . ($1 + 1);
9967             }
9968             }
9969              
9970 0 0       0 # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
9971 0         0 elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9972             if ($1 <= $parens) {
9973             $char[$i] = '\\' . ($1 + 1);
9974             }
9975             }
9976              
9977 0 0       0 # $0 --> $0
9978 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9979             if ($ignorecase) {
9980             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9981             }
9982 0 0       0 }
9983 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9984             if ($ignorecase) {
9985             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9986             }
9987             }
9988              
9989             # $$ --> $$
9990             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9991             }
9992              
9993             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9994 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9995 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9996 0         0 $char[$i] = e_capture($1);
9997             if ($ignorecase) {
9998             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
9999             }
10000 0         0 }
10001 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10002 0         0 $char[$i] = e_capture($1);
10003             if ($ignorecase) {
10004             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10005             }
10006             }
10007              
10008 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10009 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
10010 0         0 $char[$i] = e_capture($1.'->'.$2);
10011             if ($ignorecase) {
10012             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10013             }
10014             }
10015              
10016 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10017 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
10018 0         0 $char[$i] = e_capture($1.'->'.$2);
10019             if ($ignorecase) {
10020             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10021             }
10022             }
10023              
10024 0         0 # $$foo
10025 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10026 0         0 $char[$i] = e_capture($1);
10027             if ($ignorecase) {
10028             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10029             }
10030             }
10031              
10032 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
10033 4         18 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10034             if ($ignorecase) {
10035             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::PREMATCH())]}';
10036 0         0 }
10037             else {
10038             $char[$i] = '@{[Ebig5hkscs::PREMATCH()]}';
10039             }
10040             }
10041              
10042 4 50       16 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
10043 4         16 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10044             if ($ignorecase) {
10045             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::MATCH())]}';
10046 0         0 }
10047             else {
10048             $char[$i] = '@{[Ebig5hkscs::MATCH()]}';
10049             }
10050             }
10051              
10052 4 50       19 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
10053 3         12 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10054             if ($ignorecase) {
10055             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::POSTMATCH())]}';
10056 0         0 }
10057             else {
10058             $char[$i] = '@{[Ebig5hkscs::POSTMATCH()]}';
10059             }
10060             }
10061              
10062 3 0       13 # ${ foo }
10063 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
10064             if ($ignorecase) {
10065             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10066             }
10067             }
10068              
10069 0         0 # ${ ... }
10070 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10071 0         0 $char[$i] = e_capture($1);
10072             if ($ignorecase) {
10073             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10074             }
10075             }
10076              
10077 0         0 # $scalar or @array
10078 13 50       53 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10079 13         68 $char[$i] = e_string($char[$i]);
10080             if ($ignorecase) {
10081             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10082             }
10083             }
10084              
10085 0 50       0 # quote character before ? + * {
10086             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10087             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10088 23         133 }
10089             else {
10090             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10091             }
10092             }
10093             }
10094 23         122  
10095 142         392 # make regexp string
10096 142         405 my $prematch = '';
10097 142 50       276 $prematch = "($anchor)";
10098 142         387 $modifier =~ tr/i//d;
10099             if ($left_e > $right_e) {
10100 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
10101             }
10102             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10103             }
10104              
10105             #
10106             # escape regexp (s'here'' or s'here''b)
10107 142     96 0 1774 #
10108 96   100     201 sub e_s1_q {
10109             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10110 96         250 $modifier ||= '';
10111 96 50       133  
10112 96         280 $modifier =~ tr/p//d;
10113 0         0 if ($modifier =~ /([adlu])/oxms) {
10114 0 0       0 my $line = 0;
10115 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10116 0         0 if ($filename ne __FILE__) {
10117             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10118             last;
10119 0         0 }
10120             }
10121             die qq{Unsupported modifier "$1" used at line $line.\n};
10122 0         0 }
10123              
10124             $slash = 'div';
10125 96 100       135  
    100          
10126 96         211 # literal null string pattern
10127 8         11 if ($string eq '') {
10128 8         11 $modifier =~ tr/bB//d;
10129             $modifier =~ tr/i//d;
10130             return join '', $ope, $delimiter, $end_delimiter, $modifier;
10131             }
10132              
10133 8         48 # with /b /B modifier
10134             elsif ($modifier =~ tr/bB//d) {
10135             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
10136             }
10137              
10138 44         94 # without /b /B modifier
10139             else {
10140             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
10141             }
10142             }
10143              
10144             #
10145             # escape regexp (s'here'')
10146 44     44 0 109 #
10147             sub e_s1_qt {
10148 44 100       91 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10149              
10150             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10151 44         100  
10152             # split regexp
10153             my @char = $string =~ /\G((?>
10154             [^\x81-\xFE\\\[\$\@\/] |
10155             [\x81-\xFE][\x00-\xFF] |
10156             \[\^ |
10157             \[\: (?>[a-z]+) \:\] |
10158             \[\:\^ (?>[a-z]+) \:\] |
10159             [\$\@\/] |
10160             \\ (?:$q_char) |
10161             (?:$q_char)
10162             ))/oxmsg;
10163 44         492  
10164 44 50 100     159 # unescape character
    50 100        
    50 66        
    50          
    100          
    100          
    50          
10165             for (my $i=0; $i <= $#char; $i++) {
10166             if (0) {
10167             }
10168 62         562  
10169 0         0 # escape last octet of multiple-octet
10170             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10171             $char[$i] = $1 . '\\' . $2;
10172             }
10173              
10174 0         0 # open character class [...]
10175 0 0       0 elsif ($char[$i] eq '[') {
10176 0         0 my $left = $i;
10177             if ($char[$i+1] eq ']') {
10178 0         0 $i++;
10179 0 0       0 }
10180 0         0 while (1) {
10181             if (++$i > $#char) {
10182 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10183 0         0 }
10184             if ($char[$i] eq ']') {
10185             my $right = $i;
10186 0         0  
10187             # [...]
10188 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
10189 0         0  
10190             $i = $left;
10191             last;
10192             }
10193             }
10194             }
10195              
10196 0         0 # open character class [^...]
10197 0 0       0 elsif ($char[$i] eq '[^') {
10198 0         0 my $left = $i;
10199             if ($char[$i+1] eq ']') {
10200 0         0 $i++;
10201 0 0       0 }
10202 0         0 while (1) {
10203             if (++$i > $#char) {
10204 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10205 0         0 }
10206             if ($char[$i] eq ']') {
10207             my $right = $i;
10208 0         0  
10209             # [^...]
10210 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10211 0         0  
10212             $i = $left;
10213             last;
10214             }
10215             }
10216             }
10217              
10218 0         0 # escape $ @ / and \
10219             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10220             $char[$i] = '\\' . $char[$i];
10221             }
10222              
10223 0         0 # rewrite character class or escape character
10224             elsif (my $char = character_class($char[$i],$modifier)) {
10225             $char[$i] = $char;
10226             }
10227              
10228 6 50       13 # /i modifier
10229 8         56 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
10230             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
10231             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
10232 8         17 }
10233             else {
10234             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
10235             }
10236             }
10237              
10238 0 0       0 # quote character before ? + * {
10239             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10240             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
10241 0         0 }
10242             else {
10243             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10244             }
10245             }
10246 0         0 }
10247 44         83  
10248 44         63 $modifier =~ tr/i//d;
10249 44         59 $delimiter = '/';
10250 44         52 $end_delimiter = '/';
10251 44         96 my $prematch = '';
10252             $prematch = "($anchor)";
10253             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10254             }
10255              
10256             #
10257             # escape regexp (s'here''b)
10258 44     44 0 299 #
10259             sub e_s1_qb {
10260             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10261 44         93  
10262             # split regexp
10263             my @char = $string =~ /\G (?>[^\\]|\\\\|[\x00-\xFF]) /oxmsg;
10264 44         166  
10265 44 50       105 # unescape character
    50          
10266             for (my $i=0; $i <= $#char; $i++) {
10267             if (0) {
10268             }
10269 98         340  
10270             # remain \\
10271             elsif ($char[$i] eq '\\\\') {
10272             }
10273              
10274 0         0 # escape $ @ / and \
10275             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10276             $char[$i] = '\\' . $char[$i];
10277             }
10278 0         0 }
10279 44         72  
10280 44         58 $delimiter = '/';
10281 44         73 $end_delimiter = '/';
10282 44         61 my $prematch = '';
10283             $prematch = q{(\G[\x00-\xFF]*?)};
10284             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10285             }
10286              
10287             #
10288             # escape regexp (s''here')
10289 44     91 0 312 #
10290             sub e_s2_q {
10291 91         159 my($ope,$delimiter,$end_delimiter,$string) = @_;
10292              
10293 91         119 $slash = 'div';
10294 91         347  
10295 91 50 66     261 my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\\\|$q_char) /oxmsg;
    50 33        
    100          
    100          
10296             for (my $i=0; $i <= $#char; $i++) {
10297             if (0) {
10298             }
10299 9         101  
10300 0         0 # escape last octet of multiple-octet
10301             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10302             $char[$i] = $1 . '\\' . $2;
10303 0         0 }
10304             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10305             $char[$i] = $1 . '\\' . $2;
10306             }
10307              
10308             # not escape \\
10309             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
10310             }
10311              
10312 0         0 # escape $ @ / and \
10313             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10314             $char[$i] = '\\' . $char[$i];
10315 5 50 66     16 }
10316 91         222 }
10317             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10318             $char[-1] = $1 . '\\' . $2;
10319 0         0 }
10320              
10321             return join '', $ope, $delimiter, @char, $end_delimiter;
10322             }
10323              
10324             #
10325             # escape regexp (s/here/and here/modifier)
10326 91     290 0 284 #
10327 290   100     2494 sub e_sub {
10328             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
10329 290         1161 $modifier ||= '';
10330 290 50       757  
10331 290         1165 $modifier =~ tr/p//d;
10332 0         0 if ($modifier =~ /([adlu])/oxms) {
10333 0 0       0 my $line = 0;
10334 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10335 0         0 if ($filename ne __FILE__) {
10336             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10337             last;
10338 0         0 }
10339             }
10340             die qq{Unsupported modifier "$1" used at line $line.\n};
10341 0 100       0 }
10342 290         744  
10343 37         61 if ($variable eq '') {
10344             $variable = '$_';
10345             $bind_operator = ' =~ ';
10346 37         54 }
10347              
10348             $slash = 'div';
10349              
10350             # P.128 Start of match (or end of previous match): \G
10351             # P.130 Advanced Use of \G with Perl
10352             # in Chapter 3: Overview of Regular Expression Features and Flavors
10353             # P.312 Iterative Matching: Scalar Context, with /g
10354             # in Chapter 7: Perl
10355             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
10356              
10357             # P.181 Where You Left Off: The \G Assertion
10358             # in Chapter 5: Pattern Matching
10359             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10360              
10361             # P.220 Where You Left Off: The \G Assertion
10362             # in Chapter 5: Pattern Matching
10363 290         496 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10364 290         453  
10365             my $e_modifier = $modifier =~ tr/e//d;
10366 290         431 my $r_modifier = $modifier =~ tr/r//d;
10367 290 50       428  
10368 290         733 my $my = '';
10369 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
10370 0         0 $my = $variable;
10371             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
10372             $variable =~ s/ = .+ \z//oxms;
10373 0         0 }
10374 290         742  
10375             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
10376             $variable_basename =~ s/ \s+ \z//oxms;
10377 290         552  
10378 290 100       454 # quote replacement string
10379 290         632 my $e_replacement = '';
10380 17         40 if ($e_modifier >= 1) {
10381             $e_replacement = e_qq('', '', '', $replacement);
10382             $e_modifier--;
10383 17 100       32 }
10384 273         570 else {
10385             if ($delimiter2 eq "'") {
10386             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
10387 91         173 }
10388             else {
10389             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
10390             }
10391 182         457 }
10392              
10393             my $sub = '';
10394 290 100       536  
10395 290 100       664 # with /r
    50          
10396             if ($r_modifier) {
10397             if (0) {
10398             }
10399 8         27  
10400 0 50       0 # s///gr with multibyte anchoring
10401             elsif ($modifier =~ /g/oxms) {
10402             $sub = sprintf(
10403             # 1 2 3 4 5
10404             q,
10405              
10406             $variable, # 1
10407             ($delimiter1 eq "'") ? # 2
10408             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10409             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10410             $s_matched, # 3
10411             $e_replacement, # 4
10412             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 5
10413             );
10414             }
10415              
10416 4 0       19 # s///gr without multibyte anchoring
10417             elsif ($modifier =~ /g/oxms) {
10418             $sub = sprintf(
10419             # 1 2 3 4 5
10420             q,
10421              
10422             $variable, # 1
10423             ($delimiter1 eq "'") ? # 2
10424             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10425             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10426             $s_matched, # 3
10427             $e_replacement, # 4
10428             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 5
10429             );
10430             }
10431              
10432             # s///r
10433 0         0 else {
10434 4         8  
10435             my $prematch = q{$`};
10436 4 50       6 $prematch = q{${1}};
10437              
10438             $sub = sprintf(
10439             # 1 2 3 4 5 6 7
10440             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Ebig5hkscs::re_r=%s; %s"%s$Ebig5hkscs::re_r$'" } : %s>,
10441              
10442             $variable, # 1
10443             ($delimiter1 eq "'") ? # 2
10444             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10445             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10446             $s_matched, # 3
10447             $e_replacement, # 4
10448             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 5
10449             $prematch, # 6
10450             $variable, # 7
10451             );
10452             }
10453 4 50       21  
10454 8         26 # $var !~ s///r doesn't make sense
10455             if ($bind_operator =~ / !~ /oxms) {
10456             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
10457             }
10458             }
10459              
10460 0 100       0 # without /r
    50          
10461             else {
10462             if (0) {
10463             }
10464 282         858  
10465 0 100       0 # s///g with multibyte anchoring
    100          
10466             elsif ($modifier =~ /g/oxms) {
10467             $sub = sprintf(
10468             # 1 2 3 4 5 6 7 8 9 10
10469             q,
10470              
10471             $variable, # 1
10472             ($delimiter1 eq "'") ? # 2
10473             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10474             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10475             $s_matched, # 3
10476             $e_replacement, # 4
10477             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 5
10478             $variable, # 6
10479             $variable, # 7
10480             $variable, # 8
10481             $variable, # 9
10482              
10483             # Binary "!~" is just like "=~" except the return value is negated in the logical sense.
10484             # It returns false if the match succeeds, and true if it fails.
10485             # (and so on)
10486              
10487             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 10
10488             );
10489             }
10490              
10491 35 0       163 # s///g without multibyte anchoring
    0          
10492             elsif ($modifier =~ /g/oxms) {
10493             $sub = sprintf(
10494             # 1 2 3 4 5 6 7 8
10495             q,
10496              
10497             $variable, # 1
10498             ($delimiter1 eq "'") ? # 2
10499             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10500             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10501             $s_matched, # 3
10502             $e_replacement, # 4
10503             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 5
10504             $variable, # 6
10505             $variable, # 7
10506             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
10507             );
10508             }
10509              
10510             # s///
10511 0         0 else {
10512 247         460  
10513             my $prematch = q{$`};
10514 247 100       408 $prematch = q{${1}};
    100          
10515              
10516             $sub = sprintf(
10517              
10518             ($bind_operator =~ / =~ /oxms) ?
10519              
10520             # 1 2 3 4 5 6 7 8
10521             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Ebig5hkscs::re_r=%s; %s%s="%s$Ebig5hkscs::re_r$'"; 1 } : undef> :
10522              
10523             # 1 2 3 4 5 6 7 8
10524             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Ebig5hkscs::re_r=%s; %s%s="%s$Ebig5hkscs::re_r$'"; undef }>,
10525              
10526             $variable, # 1
10527             $bind_operator, # 2
10528             ($delimiter1 eq "'") ? # 3
10529             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10530             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10531             $s_matched, # 4
10532             $e_replacement, # 5
10533             '$Ebig5hkscs::re_r=CORE::eval $Ebig5hkscs::re_r; ' x $e_modifier, # 6
10534             $variable, # 7
10535             $prematch, # 8
10536             );
10537             }
10538             }
10539 247 50       1238  
10540 290         811 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
10541             if ($my ne '') {
10542             $sub = "($my, $sub)[1]";
10543             }
10544 0         0  
10545 290         450 # clear s/// variable
10546             $sub_variable = '';
10547 290         395 $bind_operator = '';
10548              
10549             return $sub;
10550             }
10551              
10552             #
10553             # escape chdir (qq//, "")
10554 290     0 0 2328 #
10555             sub e_chdir {
10556 0 0       0 my($ope,$delimiter,$end_delimiter,$string) = @_;
10557 0 0       0  
10558 0 0       0 if ($^W) {
10559 0         0 if (Ebig5hkscs::_MSWin32_5Cended_path($string)) {
10560 0         0 if ($] !~ /^5\.005/oxms) {
10561             warn <
10562             @{[__FILE__]}: Can't chdir to '$string'
10563              
10564             chdir does not work with chr(0x5C) at end of path
10565             http://bugs.activestate.com/show_bug.cgi?id=81839
10566             END
10567             }
10568             }
10569 0         0 }
10570              
10571             return e_qq($ope,$delimiter,$end_delimiter,$string);
10572             }
10573              
10574             #
10575             # escape chdir (q//, '')
10576 0     2 0 0 #
10577             sub e_chdir_q {
10578 2 50       6 my($ope,$delimiter,$end_delimiter,$string) = @_;
10579 2 0       9  
10580 0 0       0 if ($^W) {
10581 0         0 if (Ebig5hkscs::_MSWin32_5Cended_path($string)) {
10582 0         0 if ($] !~ /^5\.005/oxms) {
10583             warn <
10584             @{[__FILE__]}: Can't chdir to '$string'
10585              
10586             chdir does not work with chr(0x5C) at end of path
10587             http://bugs.activestate.com/show_bug.cgi?id=81839
10588             END
10589             }
10590             }
10591 0         0 }
10592              
10593             return e_q($ope,$delimiter,$end_delimiter,$string);
10594             }
10595              
10596             #
10597             # escape regexp of split qr//
10598 2     273 0 16 #
10599 273   100     1290 sub e_split {
10600             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10601 273         1033 $modifier ||= '';
10602 273 50       533  
10603 273         674 $modifier =~ tr/p//d;
10604 0         0 if ($modifier =~ /([adlu])/oxms) {
10605 0 0       0 my $line = 0;
10606 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10607 0         0 if ($filename ne __FILE__) {
10608             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10609             last;
10610 0         0 }
10611             }
10612             die qq{Unsupported modifier "$1" used at line $line.\n};
10613 0         0 }
10614              
10615             $slash = 'div';
10616 273 100       503  
10617 273         571 # /b /B modifier
10618             if ($modifier =~ tr/bB//d) {
10619             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10620 84 100       384 }
10621 189         618  
10622             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10623             my $metachar = qr/[\@\\|[\]{^]/oxms;
10624 189         650  
10625             # split regexp
10626             my @char = $string =~ /\G((?>
10627             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
10628             \\x (?>[0-9A-Fa-f]{1,2}) |
10629             \\ (?>[0-7]{2,3}) |
10630             \\c [\x40-\x5F] |
10631             \\x\{ (?>[0-9A-Fa-f]+) \} |
10632             \\o\{ (?>[0-7]+) \} |
10633             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
10634             \\ $q_char |
10635             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
10636             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
10637             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
10638             [\$\@] $qq_variable |
10639             \$ (?>\s* [0-9]+) |
10640             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
10641             \$ \$ (?![\w\{]) |
10642             \$ (?>\s*) \$ (?>\s*) $qq_variable |
10643             \[\^ |
10644             \[\: (?>[a-z]+) :\] |
10645             \[\:\^ (?>[a-z]+) :\] |
10646             \(\? |
10647             $q_char
10648 189         16373 ))/oxmsg;
10649 189         588  
10650 189         272 my $left_e = 0;
10651             my $right_e = 0;
10652             for (my $i=0; $i <= $#char; $i++) {
10653 189 50 33     524  
    50 33        
    100          
    100          
    50          
    50          
10654 372         2335 # "\L\u" --> "\u\L"
10655             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
10656             @char[$i,$i+1] = @char[$i+1,$i];
10657             }
10658              
10659 0         0 # "\U\l" --> "\l\U"
10660             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
10661             @char[$i,$i+1] = @char[$i+1,$i];
10662             }
10663              
10664 0         0 # octal escape sequence
10665             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
10666             $char[$i] = Ebig5hkscs::octchr($1);
10667             }
10668              
10669 1         4 # hexadecimal escape sequence
10670             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
10671             $char[$i] = Ebig5hkscs::hexchr($1);
10672             }
10673              
10674             # \b{...} --> b\{...}
10675             # \B{...} --> B\{...}
10676             # \N{CHARNAME} --> N\{CHARNAME}
10677             # \p{PROPERTY} --> p\{PROPERTY}
10678 1         4 # \P{PROPERTY} --> P\{PROPERTY}
10679             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
10680             $char[$i] = $1 . '\\' . $2;
10681             }
10682              
10683 0         0 # \p, \P, \X --> p, P, X
10684             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
10685             $char[$i] = $1;
10686 0 50 100     0 }
    50 100        
    100 66        
    100 100        
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
10687              
10688             if (0) {
10689             }
10690 372         3327  
10691 0         0 # escape last octet of multiple-octet
10692             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10693             $char[$i] = $1 . '\\' . $2;
10694             }
10695              
10696 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
10697 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
10698             if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
10699             $char[$i] .= join '', splice @char, $i+1, 3;
10700 0         0 }
10701             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
10702             $char[$i] .= join '', splice @char, $i+1, 2;
10703 0         0 }
10704             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
10705             $char[$i] .= join '', splice @char, $i+1, 1;
10706             }
10707             }
10708              
10709 0         0 # open character class [...]
10710 3 50       7 elsif ($char[$i] eq '[') {
10711 3         12 my $left = $i;
10712             if ($char[$i+1] eq ']') {
10713 0         0 $i++;
10714 3 50       5 }
10715 7         16 while (1) {
10716             if (++$i > $#char) {
10717 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10718 7         14 }
10719             if ($char[$i] eq ']') {
10720             my $right = $i;
10721 3 50       6  
10722 3         24 # [...]
  0         0  
10723             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10724             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);
10725 0         0 }
10726             else {
10727             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
10728 3         15 }
10729 3         5  
10730             $i = $left;
10731             last;
10732             }
10733             }
10734             }
10735              
10736 3         10 # open character class [^...]
10737 1 50       3 elsif ($char[$i] eq '[^') {
10738 1         5 my $left = $i;
10739             if ($char[$i+1] eq ']') {
10740 0         0 $i++;
10741 1 50       2 }
10742 2         5 while (1) {
10743             if (++$i > $#char) {
10744 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10745 2         5 }
10746             if ($char[$i] eq ']') {
10747             my $right = $i;
10748 1 50       2  
10749 1         9 # [^...]
  0         0  
10750             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10751             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);
10752 0         0 }
10753             else {
10754             splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10755 1         20 }
10756 1         3  
10757             $i = $left;
10758             last;
10759             }
10760             }
10761             }
10762              
10763 1         3 # rewrite character class or escape character
10764             elsif (my $char = character_class($char[$i],$modifier)) {
10765             $char[$i] = $char;
10766             }
10767              
10768             # P.794 29.2.161. split
10769             # in Chapter 29: Functions
10770             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10771              
10772             # P.951 split
10773             # in Chapter 27: Functions
10774             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10775              
10776             # said "The //m modifier is assumed when you split on the pattern /^/",
10777             # but perl5.008 is not so. Therefore, this software adds //m.
10778             # (and so on)
10779              
10780 5         18 # split(m/^/) --> split(m/^/m)
10781             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
10782             $modifier .= 'm';
10783             }
10784              
10785 11 50       39 # /i modifier
10786 18         38 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
10787             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
10788             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
10789 18         40 }
10790             else {
10791             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
10792             }
10793             }
10794              
10795 0 50       0 # \u \l \U \L \F \Q \E
10796 2         8 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
10797             if ($right_e < $left_e) {
10798             $char[$i] = '\\' . $char[$i];
10799             }
10800 0         0 }
10801 0         0 elsif ($char[$i] eq '\u') {
10802             $char[$i] = '@{[Ebig5hkscs::ucfirst qq<';
10803             $left_e++;
10804 0         0 }
10805 0         0 elsif ($char[$i] eq '\l') {
10806             $char[$i] = '@{[Ebig5hkscs::lcfirst qq<';
10807             $left_e++;
10808 0         0 }
10809 0         0 elsif ($char[$i] eq '\U') {
10810             $char[$i] = '@{[Ebig5hkscs::uc qq<';
10811             $left_e++;
10812 0         0 }
10813 0         0 elsif ($char[$i] eq '\L') {
10814             $char[$i] = '@{[Ebig5hkscs::lc qq<';
10815             $left_e++;
10816 0         0 }
10817 0         0 elsif ($char[$i] eq '\F') {
10818             $char[$i] = '@{[Ebig5hkscs::fc qq<';
10819             $left_e++;
10820 0         0 }
10821 0         0 elsif ($char[$i] eq '\Q') {
10822             $char[$i] = '@{[CORE::quotemeta qq<';
10823             $left_e++;
10824 0 0       0 }
10825 0         0 elsif ($char[$i] eq '\E') {
10826 0         0 if ($right_e < $left_e) {
10827             $char[$i] = '>]}';
10828             $right_e++;
10829 0         0 }
10830             else {
10831             $char[$i] = '';
10832             }
10833 0         0 }
10834 0 0       0 elsif ($char[$i] eq '\Q') {
10835 0         0 while (1) {
10836             if (++$i > $#char) {
10837 0 0       0 last;
10838 0         0 }
10839             if ($char[$i] eq '\E') {
10840             last;
10841             }
10842             }
10843             }
10844             elsif ($char[$i] eq '\E') {
10845             }
10846              
10847 0 0       0 # $0 --> $0
10848 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
10849             if ($ignorecase) {
10850             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10851             }
10852 0 0       0 }
10853 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
10854             if ($ignorecase) {
10855             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10856             }
10857             }
10858              
10859             # $$ --> $$
10860             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10861             }
10862              
10863             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10864 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
10865 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10866 0         0 $char[$i] = e_capture($1);
10867             if ($ignorecase) {
10868             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10869             }
10870 0         0 }
10871 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10872 0         0 $char[$i] = e_capture($1);
10873             if ($ignorecase) {
10874             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10875             }
10876             }
10877              
10878 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10879 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
10880 0         0 $char[$i] = e_capture($1.'->'.$2);
10881             if ($ignorecase) {
10882             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10883             }
10884             }
10885              
10886 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10887 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
10888 0         0 $char[$i] = e_capture($1.'->'.$2);
10889             if ($ignorecase) {
10890             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10891             }
10892             }
10893              
10894 0         0 # $$foo
10895 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10896 0         0 $char[$i] = e_capture($1);
10897             if ($ignorecase) {
10898             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10899             }
10900             }
10901              
10902 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ebig5hkscs::PREMATCH()
10903 12         39 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10904             if ($ignorecase) {
10905             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::PREMATCH())]}';
10906 0         0 }
10907             else {
10908             $char[$i] = '@{[Ebig5hkscs::PREMATCH()]}';
10909             }
10910             }
10911              
10912 12 50       64 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ebig5hkscs::MATCH()
10913 12         36 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10914             if ($ignorecase) {
10915             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::MATCH())]}';
10916 0         0 }
10917             else {
10918             $char[$i] = '@{[Ebig5hkscs::MATCH()]}';
10919             }
10920             }
10921              
10922 12 50       70 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ebig5hkscs::POSTMATCH()
10923 9         23 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10924             if ($ignorecase) {
10925             $char[$i] = '@{[Ebig5hkscs::ignorecase(Ebig5hkscs::POSTMATCH())]}';
10926 0         0 }
10927             else {
10928             $char[$i] = '@{[Ebig5hkscs::POSTMATCH()]}';
10929             }
10930             }
10931              
10932 9 0       49 # ${ foo }
10933 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
10934             if ($ignorecase) {
10935             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $1 . ')]}';
10936             }
10937             }
10938              
10939 0         0 # ${ ... }
10940 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10941 0         0 $char[$i] = e_capture($1);
10942             if ($ignorecase) {
10943             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10944             }
10945             }
10946              
10947 0         0 # $scalar or @array
10948 3 50       8 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10949 3         14 $char[$i] = e_string($char[$i]);
10950             if ($ignorecase) {
10951             $char[$i] = '@{[Ebig5hkscs::ignorecase(' . $char[$i] . ')]}';
10952             }
10953             }
10954              
10955 0 100       0 # quote character before ? + * {
10956             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10957             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10958 7         45 }
10959             else {
10960             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10961             }
10962             }
10963             }
10964 4         23  
10965 189 50       424 # make regexp string
10966 189         406 $modifier =~ tr/i//d;
10967             if ($left_e > $right_e) {
10968 0         0 return join '', 'Ebig5hkscs::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
10969             }
10970             return join '', 'Ebig5hkscs::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
10971             }
10972              
10973             #
10974             # escape regexp of split qr''
10975 189     112 0 1656 #
10976 112   100     578 sub e_split_q {
10977             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10978 112         359 $modifier ||= '';
10979 112 50       230  
10980 112         302 $modifier =~ tr/p//d;
10981 0         0 if ($modifier =~ /([adlu])/oxms) {
10982 0 0       0 my $line = 0;
10983 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10984 0         0 if ($filename ne __FILE__) {
10985             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10986             last;
10987 0         0 }
10988             }
10989             die qq{Unsupported modifier "$1" used at line $line.\n};
10990 0         0 }
10991              
10992             $slash = 'div';
10993 112 100       197  
10994 112         255 # /b /B modifier
10995             if ($modifier =~ tr/bB//d) {
10996             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10997 56 100       261 }
10998              
10999             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
11000 56         179  
11001             # split regexp
11002             my @char = $string =~ /\G((?>
11003             [^\x81-\xFE\\\[] |
11004             [\x81-\xFE][\x00-\xFF] |
11005             \[\^ |
11006             \[\: (?>[a-z]+) \:\] |
11007             \[\:\^ (?>[a-z]+) \:\] |
11008             \\ (?:$q_char) |
11009             (?:$q_char)
11010             ))/oxmsg;
11011 56         329  
11012 56 50 33     184 # unescape character
    50 100        
    50 66        
    50 33        
    50          
    100          
    50          
11013             for (my $i=0; $i <= $#char; $i++) {
11014             if (0) {
11015             }
11016 56         549  
11017 0         0 # escape last octet of multiple-octet
11018             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
11019             $char[$i] = $1 . '\\' . $2;
11020             }
11021              
11022 0         0 # open character class [...]
11023 0 0       0 elsif ($char[$i] eq '[') {
11024 0         0 my $left = $i;
11025             if ($char[$i+1] eq ']') {
11026 0         0 $i++;
11027 0 0       0 }
11028 0         0 while (1) {
11029             if (++$i > $#char) {
11030 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11031 0         0 }
11032             if ($char[$i] eq ']') {
11033             my $right = $i;
11034 0         0  
11035             # [...]
11036 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_qr(@char[$left+1..$right-1], $modifier);
11037 0         0  
11038             $i = $left;
11039             last;
11040             }
11041             }
11042             }
11043              
11044 0         0 # open character class [^...]
11045 0 0       0 elsif ($char[$i] eq '[^') {
11046 0         0 my $left = $i;
11047             if ($char[$i+1] eq ']') {
11048 0         0 $i++;
11049 0 0       0 }
11050 0         0 while (1) {
11051             if (++$i > $#char) {
11052 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11053 0         0 }
11054             if ($char[$i] eq ']') {
11055             my $right = $i;
11056 0         0  
11057             # [^...]
11058 0         0 splice @char, $left, $right-$left+1, Ebig5hkscs::charlist_not_qr(@char[$left+1..$right-1], $modifier);
11059 0         0  
11060             $i = $left;
11061             last;
11062             }
11063             }
11064             }
11065              
11066 0         0 # rewrite character class or escape character
11067             elsif (my $char = character_class($char[$i],$modifier)) {
11068             $char[$i] = $char;
11069             }
11070              
11071 0         0 # split(m/^/) --> split(m/^/m)
11072             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
11073             $modifier .= 'm';
11074             }
11075              
11076 0 50       0 # /i modifier
11077 12         30 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ebig5hkscs::uc($char[$i]) ne Ebig5hkscs::fc($char[$i]))) {
11078             if (CORE::length(Ebig5hkscs::fc($char[$i])) == 1) {
11079             $char[$i] = '[' . Ebig5hkscs::uc($char[$i]) . Ebig5hkscs::fc($char[$i]) . ']';
11080 12         33 }
11081             else {
11082             $char[$i] = '(?:' . Ebig5hkscs::uc($char[$i]) . '|' . Ebig5hkscs::fc($char[$i]) . ')';
11083             }
11084             }
11085              
11086 0 0       0 # quote character before ? + * {
11087             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
11088             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
11089 0         0 }
11090             else {
11091             $char[$i-1] = '(?:' . $char[$i-1] . ')';
11092             }
11093             }
11094 0         0 }
11095 56         184  
11096             $modifier =~ tr/i//d;
11097             return join '', 'Ebig5hkscs::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
11098             }
11099              
11100             #
11101             # escape use without import
11102 56     0 0 287 #
11103             sub e_use_noimport {
11104 0           my($module) = @_;
11105              
11106 0           my $expr = _pathof($module);
11107 0            
11108             my $fh = gensym();
11109 0 0         for my $realfilename (_realfilename($expr)) {
11110 0            
11111 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11112 0 0         local $/ = undef; # slurp mode
11113             my $script = <$fh>;
11114 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11115 0            
11116             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11117 0           return qq;
11118             }
11119             last;
11120             }
11121 0           }
11122              
11123             return qq;
11124             }
11125              
11126             #
11127             # escape no without unimport
11128 0     0 0   #
11129             sub e_no_nounimport {
11130 0           my($module) = @_;
11131              
11132 0           my $expr = _pathof($module);
11133 0            
11134             my $fh = gensym();
11135 0 0         for my $realfilename (_realfilename($expr)) {
11136 0            
11137 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11138 0 0         local $/ = undef; # slurp mode
11139             my $script = <$fh>;
11140 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11141 0            
11142             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11143 0           return qq;
11144             }
11145             last;
11146             }
11147 0           }
11148              
11149             return qq;
11150             }
11151              
11152             #
11153             # escape use with import no parameter
11154 0     0 0   #
11155             sub e_use_noparam {
11156 0           my($module) = @_;
11157              
11158 0           my $expr = _pathof($module);
11159 0            
11160             my $fh = gensym();
11161 0 0         for my $realfilename (_realfilename($expr)) {
11162 0            
11163 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11164 0 0         local $/ = undef; # slurp mode
11165             my $script = <$fh>;
11166 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11167              
11168             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11169              
11170             # P.326 UNIVERSAL: The Ultimate Ancestor Class
11171             # in Chapter 12: Objects
11172             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
11173              
11174             # P.435 UNIVERSAL: The Ultimate Ancestor Class
11175             # in Chapter 12: Objects
11176             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
11177              
11178 0           # (and so on)
11179              
11180 0           return qq[BEGIN { Ebig5hkscs::require '$expr'; $module->import() if $module->can('import'); }];
11181             }
11182             last;
11183             }
11184 0           }
11185              
11186             return qq;
11187             }
11188              
11189             #
11190             # escape no with unimport no parameter
11191 0     0 0   #
11192             sub e_no_noparam {
11193 0           my($module) = @_;
11194              
11195 0           my $expr = _pathof($module);
11196 0            
11197             my $fh = gensym();
11198 0 0         for my $realfilename (_realfilename($expr)) {
11199 0            
11200 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11201 0 0         local $/ = undef; # slurp mode
11202             my $script = <$fh>;
11203 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11204 0            
11205             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11206 0           return qq[BEGIN { Ebig5hkscs::require '$expr'; $module->unimport() if $module->can('unimport'); }];
11207             }
11208             last;
11209             }
11210 0           }
11211              
11212             return qq;
11213             }
11214              
11215             #
11216             # escape use with import parameters
11217 0     0 0   #
11218             sub e_use {
11219 0           my($module,$list) = @_;
11220              
11221 0           my $expr = _pathof($module);
11222 0            
11223             my $fh = gensym();
11224 0 0         for my $realfilename (_realfilename($expr)) {
11225 0            
11226 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11227 0 0         local $/ = undef; # slurp mode
11228             my $script = <$fh>;
11229 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11230 0            
11231             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11232 0           return qq[BEGIN { Ebig5hkscs::require '$expr'; $module->import($list) if $module->can('import'); }];
11233             }
11234             last;
11235             }
11236 0           }
11237              
11238             return qq;
11239             }
11240              
11241             #
11242             # escape no with unimport parameters
11243 0     0 0   #
11244             sub e_no {
11245 0           my($module,$list) = @_;
11246              
11247 0           my $expr = _pathof($module);
11248 0            
11249             my $fh = gensym();
11250 0 0         for my $realfilename (_realfilename($expr)) {
11251 0            
11252 0           if (Ebig5hkscs::_open_r($fh, $realfilename)) {
11253 0 0         local $/ = undef; # slurp mode
11254             my $script = <$fh>;
11255 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11256 0            
11257             if ($script =~ /^ (?>\s*) use (?>\s+) Big5HKSCS (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11258 0           return qq[BEGIN { Ebig5hkscs::require '$expr'; $module->unimport($list) if $module->can('unimport'); }];
11259             }
11260             last;
11261             }
11262 0           }
11263              
11264             return qq;
11265             }
11266              
11267             #
11268             # file path of module
11269 0     0     #
11270             sub _pathof {
11271 0 0         my($expr) = @_;
11272 0            
11273             if ($^O eq 'MacOS') {
11274             $expr =~ s#::#:#g;
11275 0           }
11276             else {
11277 0 0         $expr =~ s#::#/#g;
11278             }
11279 0           $expr .= '.pm' if $expr !~ / \.pm \z/oxmsi;
11280              
11281             return $expr;
11282             }
11283              
11284             #
11285             # real file name of module
11286 0     0     #
11287             sub _realfilename {
11288 0 0         my($expr) = @_;
11289 0            
  0            
11290             if ($^O eq 'MacOS') {
11291             return map {"$_$expr"} @INC;
11292 0           }
  0            
11293             else {
11294             return map {"$_/$expr"} @INC;
11295             }
11296             }
11297              
11298             #
11299             # instead of Carp::carp
11300 0     0 0   #
11301 0           sub carp {
11302             my($package,$filename,$line) = caller(1);
11303             print STDERR "@_ at $filename line $line.\n";
11304             }
11305              
11306             #
11307             # instead of Carp::croak
11308 0     0 0   #
11309 0           sub croak {
11310 0           my($package,$filename,$line) = caller(1);
11311             print STDERR "@_ at $filename line $line.\n";
11312             die "\n";
11313             }
11314              
11315             #
11316             # instead of Carp::cluck
11317 0     0 0   #
11318 0           sub cluck {
11319 0           my $i = 0;
11320 0           my @cluck = ();
11321 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11322             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
11323 0           $i++;
11324 0           }
11325 0           print STDERR CORE::reverse @cluck;
11326             print STDERR "\n";
11327             print STDERR @_;
11328             }
11329              
11330             #
11331             # instead of Carp::confess
11332 0     0 0   #
11333 0           sub confess {
11334 0           my $i = 0;
11335 0           my @confess = ();
11336 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11337             push @confess, "[$i] $filename($line) $package::$subroutine\n";
11338 0           $i++;
11339 0           }
11340 0           print STDERR CORE::reverse @confess;
11341 0           print STDERR "\n";
11342             print STDERR @_;
11343             die "\n";
11344             }
11345              
11346             1;
11347              
11348             __END__