File Coverage

blib/lib/Eeuctw.pm
Criterion Covered Total %
statement 1072 3267 32.8
branch 1115 2804 39.7
condition 145 361 40.1
subroutine 57 113 50.4
pod 7 76 9.2
total 2396 6621 36.1


line stmt bran cond sub pod time code
1             package Eeuctw;
2 329     329   2095 use strict;
  329         611  
  329         15126  
3             ######################################################################
4             #
5             # Eeuctw - Run-time routines for EUCTW.pm
6             #
7             # http://search.cpan.org/dist/Char-EUCTW/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 329     329   5049 use 5.00503; # Galapagos Consensus 1998 for primetools
  329         1292  
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 329     329   5934 use vars qw($VERSION);
  329         645  
  329         50848  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 329 50   329   2505 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 329         887 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 329         47654 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 329     329   25339 CORE::eval q{
  329     329   2096  
  329     122   736  
  329         44380  
  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 329 50       148705 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     0 0 0 my($name) = @_;
78              
79 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
80 0         0 return $name;
81             }
82             elsif (Eeuctw::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Eeuctw::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 0         0 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 0   0 0 0 if (defined $_[1]) {
117 329     329   2410 no strict qw(refs);
  329         659  
  329         29183  
118 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 329     329   2339 no strict qw(refs);
  329     0   566  
  329         76080  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
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{[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF]|[\x00-\xFF]};
153 329     329   2424 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  329         910  
  329         23275  
154 329     329   2185 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  329         569  
  329         418255  
155              
156             #
157             # EUC-TW character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # EUC-TW 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 Eeuctw \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0x8D],
180             [0x8F..0xA0],
181             [0xFF..0xFF],
182             ],
183             2 => [ [0xA1..0xFE],[0xA1..0xFE],
184             ],
185             4 => [ [0x8E..0x8E],[0xA1..0xB0],[0xA1..0xFE],[0xA1..0xFE],
186             ],
187             );
188             }
189              
190             else {
191             croak "Don't know my package name '@{[__PACKAGE__]}'";
192             }
193              
194             #
195             # @ARGV wildcard globbing
196             #
197             sub import {
198              
199 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
200 0         0 my @argv = ();
201 0         0 for (@ARGV) {
202              
203             # has space
204 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
205 0 0       0 if (my @glob = Eeuctw::glob(qq{"$_"})) {
206 0         0 push @argv, @glob;
207             }
208             else {
209 0         0 push @argv, $_;
210             }
211             }
212              
213             # has wildcard metachar
214             elsif (/\A (?:$q_char)*? [*?] /oxms) {
215 0 0       0 if (my @glob = Eeuctw::glob($_)) {
216 0         0 push @argv, @glob;
217             }
218             else {
219 0         0 push @argv, $_;
220             }
221             }
222              
223             # no wildcard globbing
224             else {
225 0         0 push @argv, $_;
226             }
227             }
228 0         0 @ARGV = @argv;
229             }
230              
231 0         0 *Char::ord = \&EUCTW::ord;
232 0         0 *Char::ord_ = \&EUCTW::ord_;
233 0         0 *Char::reverse = \&EUCTW::reverse;
234 0         0 *Char::getc = \&EUCTW::getc;
235 0         0 *Char::length = \&EUCTW::length;
236 0         0 *Char::substr = \&EUCTW::substr;
237 0         0 *Char::index = \&EUCTW::index;
238 0         0 *Char::rindex = \&EUCTW::rindex;
239 0         0 *Char::eval = \&EUCTW::eval;
240 0         0 *Char::escape = \&EUCTW::escape;
241 0         0 *Char::escape_token = \&EUCTW::escape_token;
242 0         0 *Char::escape_script = \&EUCTW::escape_script;
243             }
244              
245             # P.230 Care with Prototypes
246             # in Chapter 6: Subroutines
247             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
248             #
249             # If you aren't careful, you can get yourself into trouble with prototypes.
250             # But if you are careful, you can do a lot of neat things with them. This is
251             # all very powerful, of course, and should only be used in moderation to make
252             # the world a better place.
253              
254             # P.332 Care with Prototypes
255             # in Chapter 7: Subroutines
256             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
257             #
258             # If you aren't careful, you can get yourself into trouble with prototypes.
259             # But if you are careful, you can do a lot of neat things with them. This is
260             # all very powerful, of course, and should only be used in moderation to make
261             # the world a better place.
262              
263             #
264             # Prototypes of subroutines
265             #
266       0     sub unimport {}
267             sub Eeuctw::split(;$$$);
268             sub Eeuctw::tr($$$$;$);
269             sub Eeuctw::chop(@);
270             sub Eeuctw::index($$;$);
271             sub Eeuctw::rindex($$;$);
272             sub Eeuctw::lcfirst(@);
273             sub Eeuctw::lcfirst_();
274             sub Eeuctw::lc(@);
275             sub Eeuctw::lc_();
276             sub Eeuctw::ucfirst(@);
277             sub Eeuctw::ucfirst_();
278             sub Eeuctw::uc(@);
279             sub Eeuctw::uc_();
280             sub Eeuctw::fc(@);
281             sub Eeuctw::fc_();
282             sub Eeuctw::ignorecase;
283             sub Eeuctw::classic_character_class;
284             sub Eeuctw::capture;
285             sub Eeuctw::chr(;$);
286             sub Eeuctw::chr_();
287             sub Eeuctw::glob($);
288             sub Eeuctw::glob_();
289              
290             sub EUCTW::ord(;$);
291             sub EUCTW::ord_();
292             sub EUCTW::reverse(@);
293             sub EUCTW::getc(;*@);
294             sub EUCTW::length(;$);
295             sub EUCTW::substr($$;$$);
296             sub EUCTW::index($$;$);
297             sub EUCTW::rindex($$;$);
298             sub EUCTW::escape(;$);
299              
300             #
301             # Regexp work
302             #
303 329         41412 use vars qw(
304             $re_a
305             $re_t
306             $re_n
307             $re_r
308 329     329   2371 );
  329         3161  
309              
310             #
311             # Character class
312             #
313 329         131821 use vars qw(
314             $dot
315             $dot_s
316             $eD
317             $eS
318             $eW
319             $eH
320             $eV
321             $eR
322             $eN
323             $not_alnum
324             $not_alpha
325             $not_ascii
326             $not_blank
327             $not_cntrl
328             $not_digit
329             $not_graph
330             $not_lower
331             $not_lower_i
332             $not_print
333             $not_punct
334             $not_space
335             $not_upper
336             $not_upper_i
337             $not_word
338             $not_xdigit
339             $eb
340             $eB
341 329     329   3668 );
  329         3320  
342              
343 329         4473145 use vars qw(
344             $anchor
345             $matched
346 329     329   2591 );
  329         604  
347             ${Eeuctw::anchor} = qr{\G(?>[^\x8E\xA1-\xFE]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])*?}oxms;
348              
349             # unless LONG_STRING_FOR_RE
350             if (1) {
351             }
352              
353             my $q_char_SADAHIRO_Tomoyuki_2002_01_17 = '';
354              
355             # Quantifiers
356             # {n,m} --- Match at least n but not more than m times
357             #
358             # n and m are limited to non-negative integral values less than a
359             # preset limit defined when perl is built. This is usually 32766 on
360             # the most common platforms.
361             #
362             # The following code is an attempt to solve the above limitations
363             # in a multi-byte anchoring.
364              
365             # avoid "Segmentation fault" and "Error: Parse exception"
366              
367             # perl5101delta
368             # http://perldoc.perl.org/perl5101delta.html
369             # In 5.10.0, the * quantifier in patterns was sometimes treated as {0,32767}
370             # [RT #60034, #60464]. For example, this match would fail:
371             # ("ab" x 32768) =~ /^(ab)*$/
372              
373             # SEE ALSO
374             #
375             # Complex regular subexpression recursion limit
376             # http://www.perlmonks.org/?node_id=810857
377             #
378             # regexp iteration limits
379             # http://www.nntp.perl.org/group/perl.perl5.porters/2009/02/msg144065.html
380             #
381             # latest Perl won't match certain regexes more than 32768 characters long
382             # http://stackoverflow.com/questions/26226630/latest-perl-wont-match-certain-regexes-more-than-32768-characters-long
383             #
384             # Break through the limitations of regular expressions of Perl
385             # http://d.hatena.ne.jp/gfx/20110212/1297512479
386              
387             if (($] >= 5.010001) or
388             # ActivePerl 5.6 or later (include 5.10.0)
389             (defined($ActivePerl::VERSION) and ($ActivePerl::VERSION > 800)) or
390             (($^O eq 'MSWin32') and ($] =~ /\A 5\.006/oxms))
391             ) {
392             my $sbcs = ''; # Single Byte Character Set
393             for my $range (@{ $range_tr{1} }) {
394             $sbcs .= sprintf('\\x%02X-\\x%02X', $range->[0], $range->[-1]);
395             }
396              
397             if (0) {
398             }
399              
400             # EUC-TW encoding
401             elsif (__PACKAGE__ =~ / \b Eeuctw \z/oxms) {
402             ${Eeuctw::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[^\x8E\xA1-\xFE] (?> [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\xA1-\xFE] )*?}oxms;
403             # **************** octets not in multiple octet char (always char boundary)
404             # ********************** 2 octet chars
405             # ************************************* 4 octet chars
406             }
407              
408             # other encoding
409             else {
410             ${Eeuctw::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[$sbcs](?:[^$sbcs][^$sbcs])*?}oxms;
411             # ******* octets not in multiple octet char (always char boundary)
412             # **************** 2 octet chars
413             }
414              
415             ${Eeuctw::anchor_SADAHIRO_Tomoyuki_2002_01_17} =
416             qr{\G(?(?=.{0,32766}\z)(?:[^\x8E\xA1-\xFE]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])*?|(?(?=[$sbcs]+\z).*?|(?:${Eeuctw::q_char_SADAHIRO_Tomoyuki_2002_01_17})))}oxms;
417             # qr{
418             # \G # (1), (2)
419             # (? # (3)
420             # (?=.{0,32766}\z) # (4)
421             # (?:[^\x8E\xA1-\xFE]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])*?| # (5)
422             # (?(?=[$sbcs]+\z) # (6)
423             # .*?| #(7)
424             # (?:${Eeuctw::q_char_SADAHIRO_Tomoyuki_2002_01_17}) # (8)
425             # ))}oxms;
426              
427             # avoid: Complex regular subexpression recursion limit (32766) exceeded at here.
428             local $^W = 0;
429              
430             if (((('A' x 32768).'B') !~ / ${Eeuctw::anchor} B /oxms) and
431             ((('A' x 32768).'B') =~ / ${Eeuctw::anchor_SADAHIRO_Tomoyuki_2002_01_17} B /oxms)
432             ) {
433             ${Eeuctw::anchor} = ${Eeuctw::anchor_SADAHIRO_Tomoyuki_2002_01_17};
434             }
435             else {
436             undef ${Eeuctw::q_char_SADAHIRO_Tomoyuki_2002_01_17};
437             }
438             }
439              
440             # (1)
441             # P.128 Start of match (or end of previous match): \G
442             # P.130 Advanced Use of \G with Perl
443             # in Chapter3: Over view of Regular Expression Features and Flavors
444             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
445              
446             # (2)
447             # P.255 Use leading anchors
448             # P.256 Expose ^ and \G at the front of expressions
449             # in Chapter6: Crafting an Efficient Expression
450             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
451              
452             # (3)
453             # P.138 Conditional: (? if then| else)
454             # in Chapter3: Over view of Regular Expression Features and Flavors
455             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
456              
457             # (4)
458             # perlre
459             # http://perldoc.perl.org/perlre.html
460             # The "*" quantifier is equivalent to {0,} , the "+" quantifier to {1,} ,
461             # and the "?" quantifier to {0,1}, ., n, and m are limited to non-negative
462             # integral values less than a preset limit defined when perl is built.
463             # This is usually 32766 on the most common platforms. The actual limit
464             # can be seen in the error message generated by code such as this:
465             # $_ **= $_ , / {$_} / for 2 .. 42;
466              
467             # (5)
468             # P.1023 Multiple-Byte Anchoring
469             # in Appendix W Perl Code Examples
470             # of ISBN 1-56592-224-7 CJKV Information Processing
471              
472             # (6)
473             # if string has only SBCS (Single Byte Character Set)
474              
475             # (7)
476             # then .*? (isn't limited to 32766)
477              
478             # (8)
479             # else EUC-TW::Regexp::Const (SADAHIRO Tomoyuki)
480             # http://homepage1.nifty.com/nomenclator/perl/shiftjis.htm#long
481             # http://search.cpan.org/~sadahiro/EUC-TW-Regexp/
482             # $PadA = ' (?:\A| [\x00-\x80\xA0-\xDF])(?:[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE]{2})*?';
483             # $PadG = '\G(?: |[\x00-\xFF]*?[\x00-\x80\xA0-\xDF])(?:[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE]{2})*?';
484             # $PadGA = '\G(?:\A|(?:[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE]{2})+?|[\x00-\xFF]*?[\x00-\x80\xA0-\xDF] (?:[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE]{2})*?)';
485              
486             ${Eeuctw::dot} = qr{(?>[^\x8E\xA1-\xFE\x0A]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
487             ${Eeuctw::dot_s} = qr{(?>[^\x8E\xA1-\xFE]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
488             ${Eeuctw::eD} = qr{(?>[^\x8E\xA1-\xFE0-9]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
489              
490             # Vertical tabs are now whitespace
491             # \s in a regex now matches a vertical tab in all circumstances.
492             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
493             # ${Eeuctw::eS} = qr{(?>[^\x8E\xA1-\xFE\x09\x0A \x0C\x0D\x20]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
494             # ${Eeuctw::eS} = qr{(?>[^\x8E\xA1-\xFE\x09\x0A\x0B\x0C\x0D\x20]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
495             ${Eeuctw::eS} = qr{(?>[^\x8E\xA1-\xFE\s]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
496              
497             ${Eeuctw::eW} = qr{(?>[^\x8E\xA1-\xFE0-9A-Z_a-z]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
498             ${Eeuctw::eH} = qr{(?>[^\x8E\xA1-\xFE\x09\x20]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
499             ${Eeuctw::eV} = qr{(?>[^\x8E\xA1-\xFE\x0A\x0B\x0C\x0D]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
500             ${Eeuctw::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
501             ${Eeuctw::eN} = qr{(?>[^\x8E\xA1-\xFE\x0A]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
502             ${Eeuctw::not_alnum} = qr{(?>[^\x8E\xA1-\xFE\x30-\x39\x41-\x5A\x61-\x7A]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
503             ${Eeuctw::not_alpha} = qr{(?>[^\x8E\xA1-\xFE\x41-\x5A\x61-\x7A]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
504             ${Eeuctw::not_ascii} = qr{(?>[^\x8E\xA1-\xFE\x00-\x7F]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
505             ${Eeuctw::not_blank} = qr{(?>[^\x8E\xA1-\xFE\x09\x20]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
506             ${Eeuctw::not_cntrl} = qr{(?>[^\x8E\xA1-\xFE\x00-\x1F\x7F]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
507             ${Eeuctw::not_digit} = qr{(?>[^\x8E\xA1-\xFE\x30-\x39]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
508             ${Eeuctw::not_graph} = qr{(?>[^\x8E\xA1-\xFE\x21-\x7F]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
509             ${Eeuctw::not_lower} = qr{(?>[^\x8E\xA1-\xFE\x61-\x7A]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
510             ${Eeuctw::not_lower_i} = qr{(?>[^\x8E\xA1-\xFE\x41-\x5A\x61-\x7A]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
511             # ${Eeuctw::not_lower_i} = qr{(?>[^\x8E\xA1-\xFE]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])}; # older Perl compatible
512             ${Eeuctw::not_print} = qr{(?>[^\x8E\xA1-\xFE\x20-\x7F]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
513             ${Eeuctw::not_punct} = qr{(?>[^\x8E\xA1-\xFE\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
514             ${Eeuctw::not_space} = qr{(?>[^\x8E\xA1-\xFE\s\x0B]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
515             ${Eeuctw::not_upper} = qr{(?>[^\x8E\xA1-\xFE\x41-\x5A]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
516             ${Eeuctw::not_upper_i} = qr{(?>[^\x8E\xA1-\xFE\x41-\x5A\x61-\x7A]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
517             # ${Eeuctw::not_upper_i} = qr{(?>[^\x8E\xA1-\xFE]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])}; # older Perl compatible
518             ${Eeuctw::not_word} = qr{(?>[^\x8E\xA1-\xFE\x30-\x39\x41-\x5A\x5F\x61-\x7A]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
519             ${Eeuctw::not_xdigit} = qr{(?>[^\x8E\xA1-\xFE\x30-\x39\x41-\x46\x61-\x66]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])};
520             ${Eeuctw::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))};
521             ${Eeuctw::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]))};
522              
523             # avoid: Name "Eeuctw::foo" used only once: possible typo at here.
524             ${Eeuctw::dot} = ${Eeuctw::dot};
525             ${Eeuctw::dot_s} = ${Eeuctw::dot_s};
526             ${Eeuctw::eD} = ${Eeuctw::eD};
527             ${Eeuctw::eS} = ${Eeuctw::eS};
528             ${Eeuctw::eW} = ${Eeuctw::eW};
529             ${Eeuctw::eH} = ${Eeuctw::eH};
530             ${Eeuctw::eV} = ${Eeuctw::eV};
531             ${Eeuctw::eR} = ${Eeuctw::eR};
532             ${Eeuctw::eN} = ${Eeuctw::eN};
533             ${Eeuctw::not_alnum} = ${Eeuctw::not_alnum};
534             ${Eeuctw::not_alpha} = ${Eeuctw::not_alpha};
535             ${Eeuctw::not_ascii} = ${Eeuctw::not_ascii};
536             ${Eeuctw::not_blank} = ${Eeuctw::not_blank};
537             ${Eeuctw::not_cntrl} = ${Eeuctw::not_cntrl};
538             ${Eeuctw::not_digit} = ${Eeuctw::not_digit};
539             ${Eeuctw::not_graph} = ${Eeuctw::not_graph};
540             ${Eeuctw::not_lower} = ${Eeuctw::not_lower};
541             ${Eeuctw::not_lower_i} = ${Eeuctw::not_lower_i};
542             ${Eeuctw::not_print} = ${Eeuctw::not_print};
543             ${Eeuctw::not_punct} = ${Eeuctw::not_punct};
544             ${Eeuctw::not_space} = ${Eeuctw::not_space};
545             ${Eeuctw::not_upper} = ${Eeuctw::not_upper};
546             ${Eeuctw::not_upper_i} = ${Eeuctw::not_upper_i};
547             ${Eeuctw::not_word} = ${Eeuctw::not_word};
548             ${Eeuctw::not_xdigit} = ${Eeuctw::not_xdigit};
549             ${Eeuctw::eb} = ${Eeuctw::eb};
550             ${Eeuctw::eB} = ${Eeuctw::eB};
551              
552             #
553             # EUC-TW split
554             #
555             sub Eeuctw::split(;$$$) {
556              
557             # P.794 29.2.161. split
558             # in Chapter 29: Functions
559             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
560              
561             # P.951 split
562             # in Chapter 27: Functions
563             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
564              
565 0     0 0 0 my $pattern = $_[0];
566 0         0 my $string = $_[1];
567 0         0 my $limit = $_[2];
568              
569             # if $pattern is also omitted or is the literal space, " "
570 0 0       0 if (not defined $pattern) {
571 0         0 $pattern = ' ';
572             }
573              
574             # if $string is omitted, the function splits the $_ string
575 0 0       0 if (not defined $string) {
576 0 0       0 if (defined $_) {
577 0         0 $string = $_;
578             }
579             else {
580 0         0 $string = '';
581             }
582             }
583              
584 0         0 my @split = ();
585              
586             # when string is empty
587 0 0       0 if ($string eq '') {
    0          
588              
589             # resulting list value in list context
590 0 0       0 if (wantarray) {
591 0         0 return @split;
592             }
593              
594             # count of substrings in scalar context
595             else {
596 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
597 0         0 @_ = @split;
598 0         0 return scalar @_;
599             }
600             }
601              
602             # split's first argument is more consistently interpreted
603             #
604             # After some changes earlier in v5.17, split's behavior has been simplified:
605             # if the PATTERN argument evaluates to a string containing one space, it is
606             # treated the way that a literal string containing one space once was.
607             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
608              
609             # if $pattern is also omitted or is the literal space, " ", the function splits
610             # on whitespace, /\s+/, after skipping any leading whitespace
611             # (and so on)
612              
613             elsif ($pattern eq ' ') {
614 0 0       0 if (not defined $limit) {
615 0         0 return CORE::split(' ', $string);
616             }
617             else {
618 0         0 return CORE::split(' ', $string, $limit);
619             }
620             }
621              
622 0         0 local $q_char = $q_char;
623 0 0       0 if (CORE::length($string) > 32766) {
624 0 0       0 if ($string =~ /\A [\x00-\x7F]+ \z/oxms) {
    0          
625 0         0 $q_char = qr{.}s;
626             }
627             elsif (defined ${Eeuctw::q_char_SADAHIRO_Tomoyuki_2002_01_17}) {
628 0         0 $q_char = ${Eeuctw::q_char_SADAHIRO_Tomoyuki_2002_01_17};
629             }
630             }
631              
632             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
633 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
634              
635             # a pattern capable of matching either the null string or something longer than the
636             # null string will split the value of $string into separate characters wherever it
637             # matches the null string between characters
638             # (and so on)
639              
640 0 0       0 if ('' =~ / \A $pattern \z /xms) {
641 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
642 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
643              
644             # P.1024 Appendix W.10 Multibyte Processing
645             # of ISBN 1-56592-224-7 CJKV Information Processing
646             # (and so on)
647              
648             # the //m modifier is assumed when you split on the pattern /^/
649             # (and so on)
650              
651             # V
652 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
653              
654             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
655             # is included in the resulting list, interspersed with the fields that are ordinarily returned
656             # (and so on)
657              
658 0         0 local $@;
659 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
660 0         0 push @split, CORE::eval('$' . $digit);
661             }
662             }
663             }
664              
665             else {
666 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
667              
668             # V
669 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
670 0         0 local $@;
671 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
672 0         0 push @split, CORE::eval('$' . $digit);
673             }
674             }
675             }
676             }
677              
678             elsif ($limit > 0) {
679 0 0       0 if ('' =~ / \A $pattern \z /xms) {
680 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
681 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
682              
683             # V
684 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
685 0         0 local $@;
686 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
687 0         0 push @split, CORE::eval('$' . $digit);
688             }
689             }
690             }
691             }
692             else {
693 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
694 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
695              
696             # V
697 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
698 0         0 local $@;
699 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
700 0         0 push @split, CORE::eval('$' . $digit);
701             }
702             }
703             }
704             }
705             }
706              
707 0 0       0 if (CORE::length($string) > 0) {
708 0         0 push @split, $string;
709             }
710              
711             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
712 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
713 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
714 0         0 pop @split;
715             }
716             }
717              
718             # resulting list value in list context
719 0 0       0 if (wantarray) {
720 0         0 return @split;
721             }
722              
723             # count of substrings in scalar context
724             else {
725 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
726 0         0 @_ = @split;
727 0         0 return scalar @_;
728             }
729             }
730              
731             #
732             # get last subexpression offsets
733             #
734             sub _last_subexpression_offsets {
735 0     0   0 my $pattern = $_[0];
736              
737             # remove comment
738 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
739              
740 0         0 my $modifier = '';
741 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
742 0         0 $modifier = $1;
743 0         0 $modifier =~ s/-[A-Za-z]*//;
744             }
745              
746             # with /x modifier
747 0         0 my @char = ();
748 0 0       0 if ($modifier =~ /x/oxms) {
749 0         0 @char = $pattern =~ /\G((?>
750             [^\x8E\xA1-\xFE\\\#\[\(]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
751             \\ $q_char |
752             \# (?>[^\n]*) $ |
753             \[ (?>(?:[^\x8E\xA1-\xFE\\\]]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
754             \(\? |
755             $q_char
756             ))/oxmsg;
757             }
758              
759             # without /x modifier
760             else {
761 0         0 @char = $pattern =~ /\G((?>
762             [^\x8E\xA1-\xFE\\\[\(]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
763             \\ $q_char |
764             \[ (?>(?:[^\x8E\xA1-\xFE\\\]]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
765             \(\? |
766             $q_char
767             ))/oxmsg;
768             }
769              
770 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
771             }
772              
773             #
774             # EUC-TW transliteration (tr///)
775             #
776             sub Eeuctw::tr($$$$;$) {
777              
778 0     0 0 0 my $bind_operator = $_[1];
779 0         0 my $searchlist = $_[2];
780 0         0 my $replacementlist = $_[3];
781 0   0     0 my $modifier = $_[4] || '';
782              
783 0 0       0 if ($modifier =~ /r/oxms) {
784 0 0       0 if ($bind_operator =~ / !~ /oxms) {
785 0         0 croak "Using !~ with tr///r doesn't make sense";
786             }
787             }
788              
789 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
790 0         0 my @searchlist = _charlist_tr($searchlist);
791 0         0 my @replacementlist = _charlist_tr($replacementlist);
792              
793 0         0 my %tr = ();
794 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
795 0 0       0 if (not exists $tr{$searchlist[$i]}) {
796 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
797 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
798             }
799             elsif ($modifier =~ /d/oxms) {
800 0         0 $tr{$searchlist[$i]} = '';
801             }
802             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
803 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
804             }
805             else {
806 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
807             }
808             }
809             }
810              
811 0         0 my $tr = 0;
812 0         0 my $replaced = '';
813 0 0       0 if ($modifier =~ /c/oxms) {
814 0         0 while (defined(my $char = shift @char)) {
815 0 0       0 if (not exists $tr{$char}) {
816 0 0       0 if (defined $replacementlist[0]) {
817 0         0 $replaced .= $replacementlist[0];
818             }
819 0         0 $tr++;
820 0 0       0 if ($modifier =~ /s/oxms) {
821 0   0     0 while (@char and (not exists $tr{$char[0]})) {
822 0         0 shift @char;
823 0         0 $tr++;
824             }
825             }
826             }
827             else {
828 0         0 $replaced .= $char;
829             }
830             }
831             }
832             else {
833 0         0 while (defined(my $char = shift @char)) {
834 0 0       0 if (exists $tr{$char}) {
835 0         0 $replaced .= $tr{$char};
836 0         0 $tr++;
837 0 0       0 if ($modifier =~ /s/oxms) {
838 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
839 0         0 shift @char;
840 0         0 $tr++;
841             }
842             }
843             }
844             else {
845 0         0 $replaced .= $char;
846             }
847             }
848             }
849              
850 0 0       0 if ($modifier =~ /r/oxms) {
851 0         0 return $replaced;
852             }
853             else {
854 0         0 $_[0] = $replaced;
855 0 0       0 if ($bind_operator =~ / !~ /oxms) {
856 0         0 return not $tr;
857             }
858             else {
859 0         0 return $tr;
860             }
861             }
862             }
863              
864             #
865             # EUC-TW chop
866             #
867             sub Eeuctw::chop(@) {
868              
869 0     0 0 0 my $chop;
870 0 0       0 if (@_ == 0) {
871 0         0 my @char = /\G (?>$q_char) /oxmsg;
872 0         0 $chop = pop @char;
873 0         0 $_ = join '', @char;
874             }
875             else {
876 0         0 for (@_) {
877 0         0 my @char = /\G (?>$q_char) /oxmsg;
878 0         0 $chop = pop @char;
879 0         0 $_ = join '', @char;
880             }
881             }
882 0         0 return $chop;
883             }
884              
885             #
886             # EUC-TW index by octet
887             #
888             sub Eeuctw::index($$;$) {
889              
890 0     0 1 0 my($str,$substr,$position) = @_;
891 0   0     0 $position ||= 0;
892 0         0 my $pos = 0;
893              
894 0         0 while ($pos < CORE::length($str)) {
895 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
896 0 0       0 if ($pos >= $position) {
897 0         0 return $pos;
898             }
899             }
900 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
901 0         0 $pos += CORE::length($1);
902             }
903             else {
904 0         0 $pos += 1;
905             }
906             }
907 0         0 return -1;
908             }
909              
910             #
911             # EUC-TW reverse index
912             #
913             sub Eeuctw::rindex($$;$) {
914              
915 0     0 0 0 my($str,$substr,$position) = @_;
916 0   0     0 $position ||= CORE::length($str) - 1;
917 0         0 my $pos = 0;
918 0         0 my $rindex = -1;
919              
920 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
921 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
922 0         0 $rindex = $pos;
923             }
924 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
925 0         0 $pos += CORE::length($1);
926             }
927             else {
928 0         0 $pos += 1;
929             }
930             }
931 0         0 return $rindex;
932             }
933              
934             #
935             # EUC-TW lower case first with parameter
936             #
937             sub Eeuctw::lcfirst(@) {
938 0 0   0 0 0 if (@_) {
939 0         0 my $s = shift @_;
940 0 0 0     0 if (@_ and wantarray) {
941 0         0 return Eeuctw::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
942             }
943             else {
944 0         0 return Eeuctw::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
945             }
946             }
947             else {
948 0         0 return Eeuctw::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
949             }
950             }
951              
952             #
953             # EUC-TW lower case first without parameter
954             #
955             sub Eeuctw::lcfirst_() {
956 0     0 0 0 return Eeuctw::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
957             }
958              
959             #
960             # EUC-TW lower case with parameter
961             #
962             sub Eeuctw::lc(@) {
963 0 0   0 0 0 if (@_) {
964 0         0 my $s = shift @_;
965 0 0 0     0 if (@_ and wantarray) {
966 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
967             }
968             else {
969 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
970             }
971             }
972             else {
973 0         0 return Eeuctw::lc_();
974             }
975             }
976              
977             #
978             # EUC-TW lower case without parameter
979             #
980             sub Eeuctw::lc_() {
981 0     0 0 0 my $s = $_;
982 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
983             }
984              
985             #
986             # EUC-TW upper case first with parameter
987             #
988             sub Eeuctw::ucfirst(@) {
989 0 0   0 0 0 if (@_) {
990 0         0 my $s = shift @_;
991 0 0 0     0 if (@_ and wantarray) {
992 0         0 return Eeuctw::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
993             }
994             else {
995 0         0 return Eeuctw::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
996             }
997             }
998             else {
999 0         0 return Eeuctw::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1000             }
1001             }
1002              
1003             #
1004             # EUC-TW upper case first without parameter
1005             #
1006             sub Eeuctw::ucfirst_() {
1007 0     0 0 0 return Eeuctw::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1008             }
1009              
1010             #
1011             # EUC-TW upper case with parameter
1012             #
1013             sub Eeuctw::uc(@) {
1014 0 50   2790 0 0 if (@_) {
1015 2790         3934 my $s = shift @_;
1016 2790 50 33     3541 if (@_ and wantarray) {
1017 2790 0       4954 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1018             }
1019             else {
1020 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  2790         9084  
1021             }
1022             }
1023             else {
1024 2790         10306 return Eeuctw::uc_();
1025             }
1026             }
1027              
1028             #
1029             # EUC-TW upper case without parameter
1030             #
1031             sub Eeuctw::uc_() {
1032 0     0 0 0 my $s = $_;
1033 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1034             }
1035              
1036             #
1037             # EUC-TW fold case with parameter
1038             #
1039             sub Eeuctw::fc(@) {
1040 0 50   2865 0 0 if (@_) {
1041 2865         4010 my $s = shift @_;
1042 2865 50 33     3504 if (@_ and wantarray) {
1043 2865 0       5923 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1044             }
1045             else {
1046 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  2865         7881  
1047             }
1048             }
1049             else {
1050 2865         11032 return Eeuctw::fc_();
1051             }
1052             }
1053              
1054             #
1055             # EUC-TW fold case without parameter
1056             #
1057             sub Eeuctw::fc_() {
1058 0     0 0 0 my $s = $_;
1059 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1060             }
1061              
1062             #
1063             # EUC-TW regexp capture
1064             #
1065             {
1066             # 10.3. Creating Persistent Private Variables
1067             # in Chapter 10. Subroutines
1068             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
1069              
1070             my $last_s_matched = 0;
1071              
1072             sub Eeuctw::capture {
1073 0 0 0 0 1 0 if ($last_s_matched and ($_[0] =~ /\A (?>[1-9][0-9]*) \z/oxms)) {
1074 0         0 return $_[0] + 1;
1075             }
1076 0         0 return $_[0];
1077             }
1078              
1079             # EUC-TW mark last regexp matched
1080             sub Eeuctw::matched() {
1081 0     0 0 0 $last_s_matched = 0;
1082             }
1083              
1084             # EUC-TW mark last s/// matched
1085             sub Eeuctw::s_matched() {
1086 0     0 0 0 $last_s_matched = 1;
1087             }
1088              
1089             # P.854 31.17. use re
1090             # in Chapter 31. Pragmatic Modules
1091             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1092              
1093             # P.1026 re
1094             # in Chapter 29. Pragmatic Modules
1095             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1096              
1097             $Eeuctw::matched = qr/(?{Eeuctw::matched})/;
1098             }
1099              
1100             #
1101             # EUC-TW regexp ignore case modifier
1102             #
1103             sub Eeuctw::ignorecase {
1104              
1105 0     0 0 0 my @string = @_;
1106 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1107              
1108             # ignore case of $scalar or @array
1109 0         0 for my $string (@string) {
1110              
1111             # split regexp
1112 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1113              
1114             # unescape character
1115 0         0 for (my $i=0; $i <= $#char; $i++) {
1116 0 0       0 next if not defined $char[$i];
1117              
1118             # open character class [...]
1119 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1120 0         0 my $left = $i;
1121              
1122             # [] make die "unmatched [] in regexp ...\n"
1123              
1124 0 0       0 if ($char[$i+1] eq ']') {
1125 0         0 $i++;
1126             }
1127              
1128 0         0 while (1) {
1129 0 0       0 if (++$i > $#char) {
1130 0         0 croak "Unmatched [] in regexp";
1131             }
1132 0 0       0 if ($char[$i] eq ']') {
1133 0         0 my $right = $i;
1134 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1135              
1136             # escape character
1137 0         0 for my $char (@charlist) {
1138 0 0       0 if (0) {
1139             }
1140              
1141 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1142 0         0 $char = '\\' . $char;
1143             }
1144             }
1145              
1146             # [...]
1147 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1148              
1149 0         0 $i = $left;
1150 0         0 last;
1151             }
1152             }
1153             }
1154              
1155             # open character class [^...]
1156             elsif ($char[$i] eq '[^') {
1157 0         0 my $left = $i;
1158              
1159             # [^] make die "unmatched [] in regexp ...\n"
1160              
1161 0 0       0 if ($char[$i+1] eq ']') {
1162 0         0 $i++;
1163             }
1164              
1165 0         0 while (1) {
1166 0 0       0 if (++$i > $#char) {
1167 0         0 croak "Unmatched [] in regexp";
1168             }
1169 0 0       0 if ($char[$i] eq ']') {
1170 0         0 my $right = $i;
1171 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1172              
1173             # escape character
1174 0         0 for my $char (@charlist) {
1175 0 0       0 if (0) {
1176             }
1177              
1178 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1179 0         0 $char = '\\' . $char;
1180             }
1181             }
1182              
1183             # [^...]
1184 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1185              
1186 0         0 $i = $left;
1187 0         0 last;
1188             }
1189             }
1190             }
1191              
1192             # rewrite classic character class or escape character
1193             elsif (my $char = classic_character_class($char[$i])) {
1194 0         0 $char[$i] = $char;
1195             }
1196              
1197             # with /i modifier
1198             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1199 0         0 my $uc = Eeuctw::uc($char[$i]);
1200 0         0 my $fc = Eeuctw::fc($char[$i]);
1201 0 0       0 if ($uc ne $fc) {
1202 0 0       0 if (CORE::length($fc) == 1) {
1203 0         0 $char[$i] = '[' . $uc . $fc . ']';
1204             }
1205             else {
1206 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1207             }
1208             }
1209             }
1210             }
1211              
1212             # characterize
1213 0         0 for (my $i=0; $i <= $#char; $i++) {
1214 0 0       0 next if not defined $char[$i];
1215              
1216 0 0       0 if (0) {
1217             }
1218              
1219             # quote character before ? + * {
1220 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1221 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1222 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1223             }
1224             }
1225             }
1226              
1227 0         0 $string = join '', @char;
1228             }
1229              
1230             # make regexp string
1231 0         0 return @string;
1232             }
1233              
1234             #
1235             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1236             #
1237             sub Eeuctw::classic_character_class {
1238 0     2950 0 0 my($char) = @_;
1239              
1240             return {
1241             '\D' => '${Eeuctw::eD}',
1242             '\S' => '${Eeuctw::eS}',
1243             '\W' => '${Eeuctw::eW}',
1244             '\d' => '[0-9]',
1245              
1246             # Before Perl 5.6, \s only matched the five whitespace characters
1247             # tab, newline, form-feed, carriage return, and the space character
1248             # itself, which, taken together, is the character class [\t\n\f\r ].
1249              
1250             # Vertical tabs are now whitespace
1251             # \s in a regex now matches a vertical tab in all circumstances.
1252             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1253             # \t \n \v \f \r space
1254             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1255             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1256             '\s' => '\s',
1257              
1258             '\w' => '[0-9A-Z_a-z]',
1259             '\C' => '[\x00-\xFF]',
1260             '\X' => 'X',
1261              
1262             # \h \v \H \V
1263              
1264             # P.114 Character Class Shortcuts
1265             # in Chapter 7: In the World of Regular Expressions
1266             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1267              
1268             # P.357 13.2.3 Whitespace
1269             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1270             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1271             #
1272             # 0x00009 CHARACTER TABULATION h s
1273             # 0x0000a LINE FEED (LF) vs
1274             # 0x0000b LINE TABULATION v
1275             # 0x0000c FORM FEED (FF) vs
1276             # 0x0000d CARRIAGE RETURN (CR) vs
1277             # 0x00020 SPACE h s
1278              
1279             # P.196 Table 5-9. Alphanumeric regex metasymbols
1280             # in Chapter 5. Pattern Matching
1281             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1282              
1283             # (and so on)
1284              
1285             '\H' => '${Eeuctw::eH}',
1286             '\V' => '${Eeuctw::eV}',
1287             '\h' => '[\x09\x20]',
1288             '\v' => '[\x0A\x0B\x0C\x0D]',
1289             '\R' => '${Eeuctw::eR}',
1290              
1291             # \N
1292             #
1293             # http://perldoc.perl.org/perlre.html
1294             # Character Classes and other Special Escapes
1295             # Any character but \n (experimental). Not affected by /s modifier
1296              
1297             '\N' => '${Eeuctw::eN}',
1298              
1299             # \b \B
1300              
1301             # P.180 Boundaries: The \b and \B Assertions
1302             # in Chapter 5: Pattern Matching
1303             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1304              
1305             # P.219 Boundaries: The \b and \B Assertions
1306             # in Chapter 5: Pattern Matching
1307             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1308              
1309             # \b really means (?:(?<=\w)(?!\w)|(?
1310             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1311             '\b' => '${Eeuctw::eb}',
1312              
1313             # \B really means (?:(?<=\w)(?=\w)|(?
1314             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1315             '\B' => '${Eeuctw::eB}',
1316              
1317 2950   100     4499 }->{$char} || '';
1318             }
1319              
1320             #
1321             # prepare EUC-TW characters per length
1322             #
1323              
1324             # 1 octet characters
1325             my @chars1 = ();
1326             sub chars1 {
1327 2950 0   0 0 122750 if (@chars1) {
1328 0         0 return @chars1;
1329             }
1330 0 0       0 if (exists $range_tr{1}) {
1331 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1332 0         0 while (my @range = splice(@ranges,0,1)) {
1333 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1334 0         0 push @chars1, pack 'C', $oct0;
1335             }
1336             }
1337             }
1338 0         0 return @chars1;
1339             }
1340              
1341             # 2 octets characters
1342             my @chars2 = ();
1343             sub chars2 {
1344 0 0   0 0 0 if (@chars2) {
1345 0         0 return @chars2;
1346             }
1347 0 0       0 if (exists $range_tr{2}) {
1348 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1349 0         0 while (my @range = splice(@ranges,0,2)) {
1350 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1351 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1352 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1353             }
1354             }
1355             }
1356             }
1357 0         0 return @chars2;
1358             }
1359              
1360             # 3 octets characters
1361             my @chars3 = ();
1362             sub chars3 {
1363 0 0   0 0 0 if (@chars3) {
1364 0         0 return @chars3;
1365             }
1366 0 0       0 if (exists $range_tr{3}) {
1367 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1368 0         0 while (my @range = splice(@ranges,0,3)) {
1369 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1370 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1371 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1372 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1373             }
1374             }
1375             }
1376             }
1377             }
1378 0         0 return @chars3;
1379             }
1380              
1381             # 4 octets characters
1382             my @chars4 = ();
1383             sub chars4 {
1384 0 0   0 0 0 if (@chars4) {
1385 0         0 return @chars4;
1386             }
1387 0 0       0 if (exists $range_tr{4}) {
1388 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1389 0         0 while (my @range = splice(@ranges,0,4)) {
1390 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1391 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1392 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1393 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1394 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1395             }
1396             }
1397             }
1398             }
1399             }
1400             }
1401 0         0 return @chars4;
1402             }
1403              
1404             #
1405             # EUC-TW open character list for tr
1406             #
1407             sub _charlist_tr {
1408              
1409 0     0   0 local $_ = shift @_;
1410              
1411             # unescape character
1412 0         0 my @char = ();
1413 0         0 while (not /\G \z/oxmsgc) {
1414 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1415 0         0 push @char, '\-';
1416             }
1417             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1418 0         0 push @char, CORE::chr(oct $1);
1419             }
1420             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1421 0         0 push @char, CORE::chr(hex $1);
1422             }
1423             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1424 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1425             }
1426             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1427             push @char, {
1428             '\0' => "\0",
1429             '\n' => "\n",
1430             '\r' => "\r",
1431             '\t' => "\t",
1432             '\f' => "\f",
1433             '\b' => "\x08", # \b means backspace in character class
1434             '\a' => "\a",
1435             '\e' => "\e",
1436 0         0 }->{$1};
1437             }
1438             elsif (/\G \\ ($q_char) /oxmsgc) {
1439 0         0 push @char, $1;
1440             }
1441             elsif (/\G ($q_char) /oxmsgc) {
1442 0         0 push @char, $1;
1443             }
1444             }
1445              
1446             # join separated multiple-octet
1447 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1448              
1449             # unescape '-'
1450 0         0 my @i = ();
1451 0         0 for my $i (0 .. $#char) {
1452 0 0       0 if ($char[$i] eq '\-') {
    0          
1453 0         0 $char[$i] = '-';
1454             }
1455             elsif ($char[$i] eq '-') {
1456 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1457 0         0 push @i, $i;
1458             }
1459             }
1460             }
1461              
1462             # open character list (reverse for splice)
1463 0         0 for my $i (CORE::reverse @i) {
1464 0         0 my @range = ();
1465              
1466             # range error
1467 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1468 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1469             }
1470              
1471             # range of multiple-octet code
1472 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1473 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1474 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1475             }
1476             elsif (CORE::length($char[$i+1]) == 2) {
1477 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1478 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1479             }
1480             elsif (CORE::length($char[$i+1]) == 3) {
1481 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1482 0         0 push @range, chars2();
1483 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1484             }
1485             elsif (CORE::length($char[$i+1]) == 4) {
1486 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1487 0         0 push @range, chars2();
1488 0         0 push @range, chars3();
1489 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1490             }
1491             else {
1492 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1493             }
1494             }
1495             elsif (CORE::length($char[$i-1]) == 2) {
1496 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1497 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1498             }
1499             elsif (CORE::length($char[$i+1]) == 3) {
1500 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1501 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1502             }
1503             elsif (CORE::length($char[$i+1]) == 4) {
1504 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1505 0         0 push @range, chars3();
1506 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1507             }
1508             else {
1509 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1510             }
1511             }
1512             elsif (CORE::length($char[$i-1]) == 3) {
1513 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1514 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1515             }
1516             elsif (CORE::length($char[$i+1]) == 4) {
1517 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1518 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1519             }
1520             else {
1521 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1522             }
1523             }
1524             elsif (CORE::length($char[$i-1]) == 4) {
1525 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1526 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1527             }
1528             else {
1529 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1530             }
1531             }
1532             else {
1533 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1534             }
1535              
1536 0         0 splice @char, $i-1, 3, @range;
1537             }
1538              
1539 0         0 return @char;
1540             }
1541              
1542             #
1543             # EUC-TW open character class
1544             #
1545             sub _cc {
1546 0 50   342   0 if (scalar(@_) == 0) {
    100          
    50          
1547 342         2090 die __FILE__, ": subroutine cc got no parameter.\n";
1548             }
1549             elsif (scalar(@_) == 1) {
1550 0         0 return sprintf('\x%02X',$_[0]);
1551             }
1552             elsif (scalar(@_) == 2) {
1553 151 50       752 if ($_[0] > $_[1]) {
    50          
    100          
1554 191         610 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1555             }
1556             elsif ($_[0] == $_[1]) {
1557 0         0 return sprintf('\x%02X',$_[0]);
1558             }
1559             elsif (($_[0]+1) == $_[1]) {
1560 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1561             }
1562             else {
1563 20         74 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1564             }
1565             }
1566             else {
1567 171         945 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1568             }
1569             }
1570              
1571             #
1572             # EUC-TW octet range
1573             #
1574             sub _octets {
1575 0     557   0 my $length = shift @_;
1576              
1577 557 100       1037 if ($length == 1) {
    50          
    0          
    0          
1578 557         1583 my($a1) = unpack 'C', $_[0];
1579 426         1368 my($z1) = unpack 'C', $_[1];
1580              
1581 426 50       834 if ($a1 > $z1) {
1582 426         906 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1583             }
1584              
1585 0 100       0 if ($a1 == $z1) {
    50          
1586 426         2389 return sprintf('\x%02X',$a1);
1587             }
1588             elsif (($a1+1) == $z1) {
1589 20         78 return sprintf('\x%02X\x%02X',$a1,$z1);
1590             }
1591             else {
1592 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1593             }
1594             }
1595             elsif ($length == 2) {
1596 406         10876 my($a1,$a2) = unpack 'CC', $_[0];
1597 131         453 my($z1,$z2) = unpack 'CC', $_[1];
1598 131         283 my($A1,$A2) = unpack 'CC', $_[2];
1599 131         246 my($Z1,$Z2) = unpack 'CC', $_[3];
1600              
1601 131 100       286 if ($a1 == $z1) {
    50          
1602             return (
1603             # 11111111 222222222222
1604             # A A Z
1605 131         290 _cc($a1) . _cc($a2,$z2), # a2-z2
1606             );
1607             }
1608             elsif (($a1+1) == $z1) {
1609             return (
1610             # 11111111111 222222222222
1611             # A Z A Z
1612 111         756 _cc($a1) . _cc($a2,$Z2), # a2-
1613             _cc( $z1) . _cc($A2,$z2), # -z2
1614             );
1615             }
1616             else {
1617             return (
1618             # 1111111111111111 222222222222
1619             # A Z A Z
1620 0         0 _cc($a1) . _cc($a2,$Z2), # a2-
1621             _cc($a1+1,$z1-1) . _cc($A2,$Z2), # -
1622             _cc( $z1) . _cc($A2,$z2), # -z2
1623             );
1624             }
1625             }
1626             elsif ($length == 3) {
1627 20         79 my($a1,$a2,$a3) = unpack 'CCC', $_[0];
1628 0         0 my($z1,$z2,$z3) = unpack 'CCC', $_[1];
1629 0         0 my($A1,$A2,$A3) = unpack 'CCC', $_[2];
1630 0         0 my($Z1,$Z2,$Z3) = unpack 'CCC', $_[3];
1631              
1632 0 0       0 if ($a1 == $z1) {
    0          
1633 0 0       0 if ($a2 == $z2) {
    0          
1634             return (
1635             # 11111111 22222222 333333333333
1636             # A A A Z
1637 0         0 _cc($a1) . _cc($a2) . _cc($a3,$z3), # a3-z3
1638             );
1639             }
1640             elsif (($a2+1) == $z2) {
1641             return (
1642             # 11111111 22222222222 333333333333
1643             # A A Z A Z
1644 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1645             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1646             );
1647             }
1648             else {
1649             return (
1650             # 11111111 2222222222222222 333333333333
1651             # A A Z A Z
1652 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1653             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3), # -
1654             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1655             );
1656             }
1657             }
1658             elsif (($a1+1) == $z1) {
1659             return (
1660             # 11111111111 22222222222222 333333333333
1661             # A Z A Z A Z
1662 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1663             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1664             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1665             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1666             );
1667             }
1668             else {
1669             return (
1670             # 1111111111111111 22222222222222 333333333333
1671             # A Z A Z A Z
1672 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1673             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1674             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3), # -
1675             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1676             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1677             );
1678             }
1679             }
1680             elsif ($length == 4) {
1681 0         0 my($a1,$a2,$a3,$a4) = unpack 'CCCC', $_[0];
1682 0         0 my($z1,$z2,$z3,$z4) = unpack 'CCCC', $_[1];
1683 0         0 my($A1,$A2,$A3,$A4) = unpack 'CCCC', $_[0];
1684 0         0 my($Z1,$Z2,$Z3,$Z4) = unpack 'CCCC', $_[1];
1685              
1686 0 0       0 if ($a1 == $z1) {
    0          
1687 0 0       0 if ($a2 == $z2) {
    0          
1688 0 0       0 if ($a3 == $z3) {
    0          
1689             return (
1690             # 11111111 22222222 33333333 444444444444
1691             # A A A A Z
1692 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$z4), # a4-z4
1693             );
1694             }
1695             elsif (($a3+1) == $z3) {
1696             return (
1697             # 11111111 22222222 33333333333 444444444444
1698             # A A A Z A Z
1699 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1700             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1701             );
1702             }
1703             else {
1704             return (
1705             # 11111111 22222222 3333333333333333 444444444444
1706             # A A A Z A Z
1707 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1708             _cc($a1) . _cc($a2) . _cc($a3+1,$z3-1) . _cc($A4,$Z4), # -
1709             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1710             );
1711             }
1712             }
1713             elsif (($a2+1) == $z2) {
1714             return (
1715             # 11111111 22222222222 33333333333333 444444444444
1716             # A A Z A Z A Z
1717 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1718             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1719             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1720             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1721             );
1722             }
1723             else {
1724             return (
1725             # 11111111 2222222222222222 33333333333333 444444444444
1726             # A A Z A Z A Z
1727 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1728             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1729             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1730             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1731             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1732             );
1733             }
1734             }
1735             elsif (($a1+1) == $z1) {
1736             return (
1737             # 11111111111 22222222222222 33333333333333 444444444444
1738             # A Z A Z A Z A Z
1739 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1740             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1741             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1742             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1743             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1744             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1745             );
1746             }
1747             else {
1748             return (
1749             # 1111111111111111 22222222222222 33333333333333 444444444444
1750             # A Z A Z A Z A Z
1751 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1752             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1753             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1754             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1755             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1756             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1757             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1758             );
1759             }
1760             }
1761             else {
1762 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1763             }
1764             }
1765              
1766             #
1767             # EUC-TW range regexp
1768             #
1769             sub _range_regexp {
1770 0     517   0 my($length,$first,$last) = @_;
1771              
1772 517         1150 my @range_regexp = ();
1773 517 50       782 if (not exists $range_tr{$length}) {
1774 517         1371 return @range_regexp;
1775             }
1776              
1777 0         0 my @ranges = @{ $range_tr{$length} };
  517         739  
1778 517         1592 while (my @range = splice(@ranges,0,$length)) {
1779 517         1714 my $min = '';
1780 1289         2124 my $max = '';
1781 1289         2343 for (my $i=0; $i < $length; $i++) {
1782 1289         2366 $min .= pack 'C', $range[$i][0];
1783 1420         3282 $max .= pack 'C', $range[$i][-1];
1784             }
1785              
1786             # min___max
1787             # FIRST_____________LAST
1788             # (nothing)
1789              
1790 1420 50 66     3145 if ($max lt $first) {
    100 100        
    50 33        
    100 100        
    100 66        
    100 66        
    50 66        
1791             }
1792              
1793             # **********
1794             # min_________max
1795             # FIRST_____________LAST
1796             # **********
1797              
1798             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1799 1289         13406 push @range_regexp, _octets($length,$first,$max,$min,$max);
1800             }
1801              
1802             # **********************
1803             # min________________max
1804             # FIRST_____________LAST
1805             # **********************
1806              
1807             elsif (($min eq $first) and ($max eq $last)) {
1808 20         59 push @range_regexp, _octets($length,$first,$last,$min,$max);
1809             }
1810              
1811             # *********
1812             # min___max
1813             # FIRST_____________LAST
1814             # *********
1815              
1816             elsif (($first le $min) and ($max le $last)) {
1817 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1818             }
1819              
1820             # **********************
1821             # min__________________________max
1822             # FIRST_____________LAST
1823             # **********************
1824              
1825             elsif (($min le $first) and ($last le $max)) {
1826 40         67 push @range_regexp, _octets($length,$first,$last,$min,$max);
1827             }
1828              
1829             # *********
1830             # min________max
1831             # FIRST_____________LAST
1832             # *********
1833              
1834             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1835 477         1153 push @range_regexp, _octets($length,$min,$last,$min,$max);
1836             }
1837              
1838             # min___max
1839             # FIRST_____________LAST
1840             # (nothing)
1841              
1842             elsif ($last lt $min) {
1843             }
1844              
1845             else {
1846 20         49 die __FILE__, ": subroutine _range_regexp panic.\n";
1847             }
1848             }
1849              
1850 0         0 return @range_regexp;
1851             }
1852              
1853             #
1854             # EUC-TW open character list for qr and not qr
1855             #
1856             sub _charlist {
1857              
1858 517     758   1226 my $modifier = pop @_;
1859 758         1191 my @char = @_;
1860              
1861 758 100       5285 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1862              
1863             # unescape character
1864 758         3017 for (my $i=0; $i <= $#char; $i++) {
1865              
1866             # escape - to ...
1867 758 100 100     2679 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1868 2648 100 100     23076 if ((0 < $i) and ($i < $#char)) {
1869 522         10000 $char[$i] = '...';
1870             }
1871             }
1872              
1873             # octal escape sequence
1874             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1875 497         1176 $char[$i] = octchr($1);
1876             }
1877              
1878             # hexadecimal escape sequence
1879             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1880 0         0 $char[$i] = hexchr($1);
1881             }
1882              
1883             # \b{...} --> b\{...}
1884             # \B{...} --> B\{...}
1885             # \N{CHARNAME} --> N\{CHARNAME}
1886             # \p{PROPERTY} --> p\{PROPERTY}
1887             # \P{PROPERTY} --> P\{PROPERTY}
1888             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x8E\xA1-\xFE0-9\}][^\x8E\xA1-\xFE\}]*) \} ) \z/oxms) {
1889 0         0 $char[$i] = $1 . '\\' . $2;
1890             }
1891              
1892             # \p, \P, \X --> p, P, X
1893             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1894 0         0 $char[$i] = $1;
1895             }
1896              
1897             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1898 0         0 $char[$i] = CORE::chr oct $1;
1899             }
1900             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1901 0         0 $char[$i] = CORE::chr hex $1;
1902             }
1903             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1904 206         987 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1905             }
1906             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1907             $char[$i] = {
1908             '\0' => "\0",
1909             '\n' => "\n",
1910             '\r' => "\r",
1911             '\t' => "\t",
1912             '\f' => "\f",
1913             '\b' => "\x08", # \b means backspace in character class
1914             '\a' => "\a",
1915             '\e' => "\e",
1916             '\d' => '[0-9]',
1917              
1918             # Vertical tabs are now whitespace
1919             # \s in a regex now matches a vertical tab in all circumstances.
1920             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1921             # \t \n \v \f \r space
1922             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1923             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1924             '\s' => '\s',
1925              
1926             '\w' => '[0-9A-Z_a-z]',
1927             '\D' => '${Eeuctw::eD}',
1928             '\S' => '${Eeuctw::eS}',
1929             '\W' => '${Eeuctw::eW}',
1930              
1931             '\H' => '${Eeuctw::eH}',
1932             '\V' => '${Eeuctw::eV}',
1933             '\h' => '[\x09\x20]',
1934             '\v' => '[\x0A\x0B\x0C\x0D]',
1935             '\R' => '${Eeuctw::eR}',
1936              
1937 0         0 }->{$1};
1938             }
1939              
1940             # POSIX-style character classes
1941             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1942             $char[$i] = {
1943              
1944             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1945             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1946             '[:^lower:]' => '${Eeuctw::not_lower_i}',
1947             '[:^upper:]' => '${Eeuctw::not_upper_i}',
1948              
1949 33         535 }->{$1};
1950             }
1951             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1952             $char[$i] = {
1953              
1954             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1955             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1956             '[:ascii:]' => '[\x00-\x7F]',
1957             '[:blank:]' => '[\x09\x20]',
1958             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1959             '[:digit:]' => '[\x30-\x39]',
1960             '[:graph:]' => '[\x21-\x7F]',
1961             '[:lower:]' => '[\x61-\x7A]',
1962             '[:print:]' => '[\x20-\x7F]',
1963             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1964              
1965             # P.174 POSIX-Style Character Classes
1966             # in Chapter 5: Pattern Matching
1967             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1968              
1969             # P.311 11.2.4 Character Classes and other Special Escapes
1970             # in Chapter 11: perlre: Perl regular expressions
1971             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1972              
1973             # P.210 POSIX-Style Character Classes
1974             # in Chapter 5: Pattern Matching
1975             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1976              
1977             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1978              
1979             '[:upper:]' => '[\x41-\x5A]',
1980             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1981             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1982             '[:^alnum:]' => '${Eeuctw::not_alnum}',
1983             '[:^alpha:]' => '${Eeuctw::not_alpha}',
1984             '[:^ascii:]' => '${Eeuctw::not_ascii}',
1985             '[:^blank:]' => '${Eeuctw::not_blank}',
1986             '[:^cntrl:]' => '${Eeuctw::not_cntrl}',
1987             '[:^digit:]' => '${Eeuctw::not_digit}',
1988             '[:^graph:]' => '${Eeuctw::not_graph}',
1989             '[:^lower:]' => '${Eeuctw::not_lower}',
1990             '[:^print:]' => '${Eeuctw::not_print}',
1991             '[:^punct:]' => '${Eeuctw::not_punct}',
1992             '[:^space:]' => '${Eeuctw::not_space}',
1993             '[:^upper:]' => '${Eeuctw::not_upper}',
1994             '[:^word:]' => '${Eeuctw::not_word}',
1995             '[:^xdigit:]' => '${Eeuctw::not_xdigit}',
1996              
1997 8         55 }->{$1};
1998             }
1999             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
2000 70         1249 $char[$i] = $1;
2001             }
2002             }
2003              
2004             # open character list
2005 7         32 my @singleoctet = ();
2006 758         1292 my @multipleoctet = ();
2007 758         1127 for (my $i=0; $i <= $#char; ) {
2008              
2009             # escaped -
2010 758 100 100     1893 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
2011 2151         10554 $i += 1;
2012 497         768 next;
2013             }
2014              
2015             # make range regexp
2016             elsif ($char[$i] eq '...') {
2017              
2018             # range error
2019 497 50       1120 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    100          
2020 497         2069 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2021             }
2022             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
2023 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
2024 477         1281 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2025             }
2026             }
2027              
2028             # make range regexp per length
2029 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
2030 497         1544 my @regexp = ();
2031              
2032             # is first and last
2033 517 100 100     873 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    100 33        
    50          
    50          
2034 517         2265 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
2035             }
2036              
2037             # is first
2038             elsif ($length == CORE::length($char[$i-1])) {
2039 477         1524 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
2040             }
2041              
2042             # is inside in first and last
2043             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
2044 20         92 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
2045             }
2046              
2047             # is last
2048             elsif ($length == CORE::length($char[$i+1])) {
2049 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
2050             }
2051              
2052             else {
2053 20         74 die __FILE__, ": subroutine make_regexp panic.\n";
2054             }
2055              
2056 0 100       0 if ($length == 1) {
2057 517         8152 push @singleoctet, @regexp;
2058             }
2059             else {
2060 386         1078 push @multipleoctet, @regexp;
2061             }
2062             }
2063              
2064 131         325 $i += 2;
2065             }
2066              
2067             # with /i modifier
2068             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
2069 497 100       1183 if ($modifier =~ /i/oxms) {
2070 764         1223 my $uc = Eeuctw::uc($char[$i]);
2071 192         436 my $fc = Eeuctw::fc($char[$i]);
2072 192 50       382 if ($uc ne $fc) {
2073 192 50       617 if (CORE::length($fc) == 1) {
2074 192         363 push @singleoctet, $uc, $fc;
2075             }
2076             else {
2077 192         350 push @singleoctet, $uc;
2078 0         0 push @multipleoctet, $fc;
2079             }
2080             }
2081             else {
2082 0         0 push @singleoctet, $char[$i];
2083             }
2084             }
2085             else {
2086 0         0 push @singleoctet, $char[$i];
2087             }
2088 572         925 $i += 1;
2089             }
2090              
2091             # single character of single octet code
2092             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
2093 764         1178 push @singleoctet, "\t", "\x20";
2094 0         0 $i += 1;
2095             }
2096             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
2097 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
2098 0         0 $i += 1;
2099             }
2100             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
2101 0         0 push @singleoctet, $char[$i];
2102 2         6 $i += 1;
2103             }
2104              
2105             # single character of multiple-octet code
2106             else {
2107 2         5 push @multipleoctet, $char[$i];
2108 391         685 $i += 1;
2109             }
2110             }
2111              
2112             # quote metachar
2113 391         778 for (@singleoctet) {
2114 758 50       1590 if ($_ eq '...') {
    100          
    100          
    100          
    100          
2115 1384         7946 $_ = '-';
2116             }
2117             elsif (/\A \n \z/oxms) {
2118 0         0 $_ = '\n';
2119             }
2120             elsif (/\A \r \z/oxms) {
2121 8         19 $_ = '\r';
2122             }
2123             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
2124 8         21 $_ = sprintf('\x%02X', CORE::ord $1);
2125             }
2126             elsif (/\A [\x00-\xFF] \z/oxms) {
2127 1         6 $_ = quotemeta $_;
2128             }
2129             }
2130              
2131             # return character list
2132 939         1439 return \@singleoctet, \@multipleoctet;
2133             }
2134              
2135             #
2136             # EUC-TW octal escape sequence
2137             #
2138             sub octchr {
2139 758     5 0 2714 my($octdigit) = @_;
2140              
2141 5         13 my @binary = ();
2142 5         7 for my $octal (split(//,$octdigit)) {
2143             push @binary, {
2144             '0' => '000',
2145             '1' => '001',
2146             '2' => '010',
2147             '3' => '011',
2148             '4' => '100',
2149             '5' => '101',
2150             '6' => '110',
2151             '7' => '111',
2152 5         24 }->{$octal};
2153             }
2154 50         199 my $binary = join '', @binary;
2155              
2156             my $octchr = {
2157             # 1234567
2158             1 => pack('B*', "0000000$binary"),
2159             2 => pack('B*', "000000$binary"),
2160             3 => pack('B*', "00000$binary"),
2161             4 => pack('B*', "0000$binary"),
2162             5 => pack('B*', "000$binary"),
2163             6 => pack('B*', "00$binary"),
2164             7 => pack('B*', "0$binary"),
2165             0 => pack('B*', "$binary"),
2166              
2167 5         14 }->{CORE::length($binary) % 8};
2168              
2169 5         60 return $octchr;
2170             }
2171              
2172             #
2173             # EUC-TW hexadecimal escape sequence
2174             #
2175             sub hexchr {
2176 5     5 0 20 my($hexdigit) = @_;
2177              
2178             my $hexchr = {
2179             1 => pack('H*', "0$hexdigit"),
2180             0 => pack('H*', "$hexdigit"),
2181              
2182 5         15 }->{CORE::length($_[0]) % 2};
2183              
2184 5         41 return $hexchr;
2185             }
2186              
2187             #
2188             # EUC-TW open character list for qr
2189             #
2190             sub charlist_qr {
2191              
2192 5     519 0 18 my $modifier = pop @_;
2193 519         1073 my @char = @_;
2194              
2195 519         1471 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2196 519         1739 my @singleoctet = @$singleoctet;
2197 519         1341 my @multipleoctet = @$multipleoctet;
2198              
2199             # return character list
2200 519 100       881 if (scalar(@singleoctet) >= 1) {
2201              
2202             # with /i modifier
2203 519 100       1326 if ($modifier =~ m/i/oxms) {
2204 384         965 my %singleoctet_ignorecase = ();
2205 107         198 for (@singleoctet) {
2206 107   100     234 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2207 277         975 for my $ord (hex($1) .. hex($2)) {
2208 85         369 my $char = CORE::chr($ord);
2209 1201         1531 my $uc = Eeuctw::uc($char);
2210 1201         1621 my $fc = Eeuctw::fc($char);
2211 1201 100       1913 if ($uc eq $fc) {
2212 1201         1820 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2213             }
2214             else {
2215 612 50       1457 if (CORE::length($fc) == 1) {
2216 589         830 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2217 589         1254 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2218             }
2219             else {
2220 589         1437 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2221 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2222             }
2223             }
2224             }
2225             }
2226 0 100       0 if ($_ ne '') {
2227 277         568 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2228             }
2229             }
2230 192         1449 my $i = 0;
2231 107         151 my @singleoctet_ignorecase = ();
2232 107         190 for my $ord (0 .. 255) {
2233 107 100       235 if (exists $singleoctet_ignorecase{$ord}) {
2234 27392         47232 push @{$singleoctet_ignorecase[$i]}, $ord;
  1732         1821  
2235             }
2236             else {
2237 1732         3175 $i++;
2238             }
2239             }
2240 25660         26346 @singleoctet = ();
2241 107         237 for my $range (@singleoctet_ignorecase) {
2242 107 100       348 if (ref $range) {
2243 11257 100       60752 if (scalar(@{$range}) == 1) {
  219 50       243  
2244 219         417 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         8  
2245             }
2246 5         75 elsif (scalar(@{$range}) == 2) {
2247 214         341 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2248             }
2249             else {
2250 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  214         264  
  214         314  
2251             }
2252             }
2253             }
2254             }
2255              
2256 214         1334 my $not_anchor = '';
2257 384         594 $not_anchor = '(?![\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE])';
2258              
2259 384         549 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2260             }
2261 384 100       1118 if (scalar(@multipleoctet) >= 2) {
2262 519         1321 return '(?:' . join('|', @multipleoctet) . ')';
2263             }
2264             else {
2265 102         759 return $multipleoctet[0];
2266             }
2267             }
2268              
2269             #
2270             # EUC-TW open character list for not qr
2271             #
2272             sub charlist_not_qr {
2273              
2274 417     239 0 1811 my $modifier = pop @_;
2275 239         431 my @char = @_;
2276              
2277 239         577 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2278 239         870 my @singleoctet = @$singleoctet;
2279 239         497 my @multipleoctet = @$multipleoctet;
2280              
2281             # with /i modifier
2282 239 100       554 if ($modifier =~ m/i/oxms) {
2283 239         596 my %singleoctet_ignorecase = ();
2284 128         203 for (@singleoctet) {
2285 128   100     275 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2286 277         2046 for my $ord (hex($1) .. hex($2)) {
2287 85         477 my $char = CORE::chr($ord);
2288 1201         1880 my $uc = Eeuctw::uc($char);
2289 1201         1681 my $fc = Eeuctw::fc($char);
2290 1201 100       1872 if ($uc eq $fc) {
2291 1201         2166 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2292             }
2293             else {
2294 612 50       1944 if (CORE::length($fc) == 1) {
2295 589         1027 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2296 589         1367 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2297             }
2298             else {
2299 589         2713 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2300 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2301             }
2302             }
2303             }
2304             }
2305 0 100       0 if ($_ ne '') {
2306 277         529 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2307             }
2308             }
2309 192         1557 my $i = 0;
2310 128         179 my @singleoctet_ignorecase = ();
2311 128         182 for my $ord (0 .. 255) {
2312 128 100       229 if (exists $singleoctet_ignorecase{$ord}) {
2313 32768         41940 push @{$singleoctet_ignorecase[$i]}, $ord;
  1732         1916  
2314             }
2315             else {
2316 1732         4088 $i++;
2317             }
2318             }
2319 31036         56276 @singleoctet = ();
2320 128         226 for my $range (@singleoctet_ignorecase) {
2321 128 100       332 if (ref $range) {
2322 11257 100       23679 if (scalar(@{$range}) == 1) {
  219 50       279  
2323 219         1562 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         11  
2324             }
2325 5         93 elsif (scalar(@{$range}) == 2) {
2326 214         309 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2327             }
2328             else {
2329 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  214         273  
  214         261  
2330             }
2331             }
2332             }
2333             }
2334              
2335             # return character list
2336 214 100       1140 if (scalar(@multipleoctet) >= 1) {
2337 239 100       757 if (scalar(@singleoctet) >= 1) {
2338              
2339             # any character other than multiple-octet and single octet character class
2340 114         216 return '(?!' . join('|', @multipleoctet) . ')(?:[^\x8E\xA1-\xFE' . join('', @singleoctet) . ']|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])';
2341             }
2342             else {
2343              
2344             # any character other than multiple-octet character class
2345 70         501 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2346             }
2347             }
2348             else {
2349 44 50       366 if (scalar(@singleoctet) >= 1) {
2350              
2351             # any character other than single octet character class
2352 125         357 return '(?:[^\x8E\xA1-\xFE' . join('', @singleoctet) . ']|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])';
2353             }
2354             else {
2355              
2356             # any character
2357 125         834 return "(?:$your_char)";
2358             }
2359             }
2360             }
2361              
2362             #
2363             # open file in read mode
2364             #
2365             sub _open_r {
2366 0     658   0 my(undef,$file) = @_;
2367 329     329   5470 use Fcntl qw(O_RDONLY);
  329         2377  
  329         78145  
2368 658         2054 return CORE::sysopen($_[0], $file, &O_RDONLY);
2369             }
2370              
2371             #
2372             # open file in append mode
2373             #
2374             sub _open_a {
2375 658     329   30314 my(undef,$file) = @_;
2376 329     329   4010 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  329         3300  
  329         1224598  
2377 329         1035 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2378             }
2379              
2380             #
2381             # safe system
2382             #
2383             sub _systemx {
2384              
2385             # P.707 29.2.33. exec
2386             # in Chapter 29: Functions
2387             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2388             #
2389             # Be aware that in older releases of Perl, exec (and system) did not flush
2390             # your output buffer, so you needed to enable command buffering by setting $|
2391             # on one or more filehandles to avoid lost output in the case of exec, or
2392             # misordererd output in the case of system. This situation was largely remedied
2393             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2394              
2395             # P.855 exec
2396             # in Chapter 27: Functions
2397             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2398             #
2399             # In very old release of Perl (before v5.6), exec (and system) did not flush
2400             # your output buffer, so you needed to enable command buffering by setting $|
2401             # on one or more filehandles to avoid lost output with exec or misordered
2402             # output with system.
2403              
2404 329     329   89984 $| = 1;
2405              
2406             # P.565 23.1.2. Cleaning Up Your Environment
2407             # in Chapter 23: Security
2408             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2409              
2410             # P.656 Cleaning Up Your Environment
2411             # in Chapter 20: Security
2412             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2413              
2414             # local $ENV{'PATH'} = '.';
2415 329         1164 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2416              
2417             # P.707 29.2.33. exec
2418             # in Chapter 29: Functions
2419             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2420             #
2421             # As we mentioned earlier, exec treats a discrete list of arguments as an
2422             # indication that it should bypass shell processing. However, there is one
2423             # place where you might still get tripped up. The exec call (and system, too)
2424             # will not distinguish between a single scalar argument and an array containing
2425             # only one element.
2426             #
2427             # @args = ("echo surprise"); # just one element in list
2428             # exec @args # still subject to shell escapes
2429             # or die "exec: $!"; # because @args == 1
2430             #
2431             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2432             # first argument as the pathname, which forces the rest of the arguments to be
2433             # interpreted as a list, even if there is only one of them:
2434             #
2435             # exec { $args[0] } @args # safe even with one-argument list
2436             # or die "can't exec @args: $!";
2437              
2438             # P.855 exec
2439             # in Chapter 27: Functions
2440             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2441             #
2442             # As we mentioned earlier, exec treats a discrete list of arguments as a
2443             # directive to bypass shell processing. However, there is one place where
2444             # you might still get tripped up. The exec call (and system, too) cannot
2445             # distinguish between a single scalar argument and an array containing
2446             # only one element.
2447             #
2448             # @args = ("echo surprise"); # just one element in list
2449             # exec @args # still subject to shell escapes
2450             # || die "exec: $!"; # because @args == 1
2451             #
2452             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2453             # argument as the pathname, which forces the rest of the arguments to be
2454             # interpreted as a list, even if there is only one of them:
2455             #
2456             # exec { $args[0] } @args # safe even with one-argument list
2457             # || die "can't exec @args: $!";
2458              
2459 329         3177 return CORE::system { $_[0] } @_; # safe even with one-argument list
  329         700  
2460             }
2461              
2462             #
2463             # EUC-TW order to character (with parameter)
2464             #
2465             sub Eeuctw::chr(;$) {
2466              
2467 329 0   0 0 38607547 my $c = @_ ? $_[0] : $_;
2468              
2469 0 0       0 if ($c == 0x00) {
2470 0         0 return "\x00";
2471             }
2472             else {
2473 0         0 my @chr = ();
2474 0         0 while ($c > 0) {
2475 0         0 unshift @chr, ($c % 0x100);
2476 0         0 $c = int($c / 0x100);
2477             }
2478 0         0 return pack 'C*', @chr;
2479             }
2480             }
2481              
2482             #
2483             # EUC-TW order to character (without parameter)
2484             #
2485             sub Eeuctw::chr_() {
2486              
2487 0     0 0 0 my $c = $_;
2488              
2489 0 0       0 if ($c == 0x00) {
2490 0         0 return "\x00";
2491             }
2492             else {
2493 0         0 my @chr = ();
2494 0         0 while ($c > 0) {
2495 0         0 unshift @chr, ($c % 0x100);
2496 0         0 $c = int($c / 0x100);
2497             }
2498 0         0 return pack 'C*', @chr;
2499             }
2500             }
2501              
2502             #
2503             # EUC-TW path globbing (with parameter)
2504             #
2505             sub Eeuctw::glob($) {
2506              
2507 0 0   0 0 0 if (wantarray) {
2508 0         0 my @glob = _DOS_like_glob(@_);
2509 0         0 for my $glob (@glob) {
2510 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2511             }
2512 0         0 return @glob;
2513             }
2514             else {
2515 0         0 my $glob = _DOS_like_glob(@_);
2516 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2517 0         0 return $glob;
2518             }
2519             }
2520              
2521             #
2522             # EUC-TW path globbing (without parameter)
2523             #
2524             sub Eeuctw::glob_() {
2525              
2526 0 0   0 0 0 if (wantarray) {
2527 0         0 my @glob = _DOS_like_glob();
2528 0         0 for my $glob (@glob) {
2529 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2530             }
2531 0         0 return @glob;
2532             }
2533             else {
2534 0         0 my $glob = _DOS_like_glob();
2535 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2536 0         0 return $glob;
2537             }
2538             }
2539              
2540             #
2541             # EUC-TW path globbing via File::DosGlob 1.10
2542             #
2543             # Often I confuse "_dosglob" and "_doglob".
2544             # So, I renamed "_dosglob" to "_DOS_like_glob".
2545             #
2546             my %iter;
2547             my %entries;
2548             sub _DOS_like_glob {
2549              
2550             # context (keyed by second cxix argument provided by core)
2551 0     0   0 my($expr,$cxix) = @_;
2552              
2553             # glob without args defaults to $_
2554 0 0       0 $expr = $_ if not defined $expr;
2555              
2556             # represents the current user's home directory
2557             #
2558             # 7.3. Expanding Tildes in Filenames
2559             # in Chapter 7. File Access
2560             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2561             #
2562             # and File::HomeDir, File::HomeDir::Windows module
2563              
2564             # DOS-like system
2565 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2566 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2567             { my_home_MSWin32() }oxmse;
2568             }
2569              
2570             # UNIX-like system
2571 0 0 0     0 else {
  0         0  
2572             $expr =~ s{ \A ~ ( (?:[^\x8E\xA1-\xFE/]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])* ) }
2573             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2574             }
2575 0 0       0  
2576 0 0       0 # assume global context if not provided one
2577             $cxix = '_G_' if not defined $cxix;
2578             $iter{$cxix} = 0 if not exists $iter{$cxix};
2579 0 0       0  
2580 0         0 # if we're just beginning, do it all first
2581             if ($iter{$cxix} == 0) {
2582             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2583             }
2584 0 0       0  
2585 0         0 # chuck it all out, quick or slow
2586 0         0 if (wantarray) {
  0         0  
2587             delete $iter{$cxix};
2588             return @{delete $entries{$cxix}};
2589 0 0       0 }
  0         0  
2590 0         0 else {
  0         0  
2591             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2592             return shift @{$entries{$cxix}};
2593             }
2594 0         0 else {
2595 0         0 # return undef for EOL
2596 0         0 delete $iter{$cxix};
2597             delete $entries{$cxix};
2598             return undef;
2599             }
2600             }
2601             }
2602              
2603             #
2604             # EUC-TW path globbing subroutine
2605             #
2606 0     0   0 sub _do_glob {
2607 0         0  
2608 0         0 my($cond,@expr) = @_;
2609             my @glob = ();
2610             my $fix_drive_relative_paths = 0;
2611 0         0  
2612 0 0       0 OUTER:
2613 0 0       0 for my $expr (@expr) {
2614             next OUTER if not defined $expr;
2615 0         0 next OUTER if $expr eq '';
2616 0         0  
2617 0         0 my @matched = ();
2618 0         0 my @globdir = ();
2619 0         0 my $head = '.';
2620             my $pathsep = '/';
2621             my $tail;
2622 0 0       0  
2623 0         0 # if argument is within quotes strip em and do no globbing
2624 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2625 0 0       0 $expr = $1;
2626 0         0 if ($cond eq 'd') {
2627             if (-d $expr) {
2628             push @glob, $expr;
2629             }
2630 0 0       0 }
2631 0         0 else {
2632             if (-e $expr) {
2633             push @glob, $expr;
2634 0         0 }
2635             }
2636             next OUTER;
2637             }
2638              
2639 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2640 0 0       0 # to h:./*.pm to expand correctly
2641 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2642             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^\x8E\xA1-\xFE/\\]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF]) #$1./$2#oxms) {
2643             $fix_drive_relative_paths = 1;
2644             }
2645 0 0       0 }
2646 0 0       0  
2647 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2648 0         0 if ($tail eq '') {
2649             push @glob, $expr;
2650 0 0       0 next OUTER;
2651 0 0       0 }
2652 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2653 0         0 if (@globdir = _do_glob('d', $head)) {
2654             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2655             next OUTER;
2656 0 0 0     0 }
2657 0         0 }
2658             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2659 0         0 $head .= $pathsep;
2660             }
2661             $expr = $tail;
2662             }
2663 0 0       0  
2664 0 0       0 # If file component has no wildcards, we can avoid opendir
2665 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2666             if ($head eq '.') {
2667 0 0 0     0 $head = '';
2668 0         0 }
2669             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2670 0         0 $head .= $pathsep;
2671 0 0       0 }
2672 0 0       0 $head .= $expr;
2673 0         0 if ($cond eq 'd') {
2674             if (-d $head) {
2675             push @glob, $head;
2676             }
2677 0 0       0 }
2678 0         0 else {
2679             if (-e $head) {
2680             push @glob, $head;
2681 0         0 }
2682             }
2683 0 0       0 next OUTER;
2684 0         0 }
2685 0         0 opendir(*DIR, $head) or next OUTER;
2686             my @leaf = readdir DIR;
2687 0 0       0 closedir DIR;
2688 0         0  
2689             if ($head eq '.') {
2690 0 0 0     0 $head = '';
2691 0         0 }
2692             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2693             $head .= $pathsep;
2694 0         0 }
2695 0         0  
2696 0         0 my $pattern = '';
2697             while ($expr =~ / \G ($q_char) /oxgc) {
2698             my $char = $1;
2699              
2700             # 6.9. Matching Shell Globs as Regular Expressions
2701             # in Chapter 6. Pattern Matching
2702             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2703 0 0       0 # (and so on)
    0          
    0          
2704 0         0  
2705             if ($char eq '*') {
2706             $pattern .= "(?:$your_char)*",
2707 0         0 }
2708             elsif ($char eq '?') {
2709             $pattern .= "(?:$your_char)?", # DOS style
2710             # $pattern .= "(?:$your_char)", # UNIX style
2711 0         0 }
2712             elsif ((my $fc = Eeuctw::fc($char)) ne $char) {
2713             $pattern .= $fc;
2714 0         0 }
2715             else {
2716             $pattern .= quotemeta $char;
2717 0     0   0 }
  0         0  
2718             }
2719             my $matchsub = sub { Eeuctw::fc($_[0]) =~ /\A $pattern \z/xms };
2720              
2721             # if ($@) {
2722             # print STDERR "$0: $@\n";
2723             # next OUTER;
2724             # }
2725 0         0  
2726 0 0 0     0 INNER:
2727 0         0 for my $leaf (@leaf) {
2728             if ($leaf eq '.' or $leaf eq '..') {
2729 0 0 0     0 next INNER;
2730 0         0 }
2731             if ($cond eq 'd' and not -d "$head$leaf") {
2732             next INNER;
2733 0 0       0 }
2734 0         0  
2735 0         0 if (&$matchsub($leaf)) {
2736             push @matched, "$head$leaf";
2737             next INNER;
2738             }
2739              
2740             # [DOS compatibility special case]
2741 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2742              
2743             if (Eeuctw::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2744             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2745 0 0       0 Eeuctw::index($pattern,'\\.') != -1 # pattern has a dot.
2746 0         0 ) {
2747 0         0 if (&$matchsub("$leaf.")) {
2748             push @matched, "$head$leaf";
2749             next INNER;
2750             }
2751 0 0       0 }
2752 0         0 }
2753             if (@matched) {
2754             push @glob, @matched;
2755 0 0       0 }
2756 0         0 }
2757 0         0 if ($fix_drive_relative_paths) {
2758             for my $glob (@glob) {
2759             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2760 0         0 }
2761             }
2762             return @glob;
2763             }
2764              
2765             #
2766             # EUC-TW parse line
2767             #
2768 0     0   0 sub _parse_line {
2769              
2770 0         0 my($line) = @_;
2771 0         0  
2772 0         0 $line .= ' ';
2773             my @piece = ();
2774             while ($line =~ /
2775             " ( (?>(?: [^\x8E\xA1-\xFE"] |[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] )* ) ) " (?>\s+) |
2776             ( (?>(?: [^\x8E\xA1-\xFE"\s]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] )* ) ) (?>\s+)
2777 0 0       0 /oxmsg
2778             ) {
2779 0         0 push @piece, defined($1) ? $1 : $2;
2780             }
2781             return @piece;
2782             }
2783              
2784             #
2785             # EUC-TW parse path
2786             #
2787 0     0   0 sub _parse_path {
2788              
2789 0         0 my($path,$pathsep) = @_;
2790 0         0  
2791 0         0 $path .= '/';
2792             my @subpath = ();
2793             while ($path =~ /
2794             ((?: [^\x8E\xA1-\xFE\/\\]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] )+?) [\/\\]
2795 0         0 /oxmsg
2796             ) {
2797             push @subpath, $1;
2798 0         0 }
2799 0         0  
2800 0         0 my $tail = pop @subpath;
2801             my $head = join $pathsep, @subpath;
2802             return $head, $tail;
2803             }
2804              
2805             #
2806             # via File::HomeDir::Windows 1.00
2807             #
2808             sub my_home_MSWin32 {
2809              
2810             # A lot of unix people and unix-derived tools rely on
2811 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2812 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2813             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2814             return $ENV{'HOME'};
2815             }
2816              
2817 0         0 # Do we have a user profile?
2818             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2819             return $ENV{'USERPROFILE'};
2820             }
2821              
2822 0         0 # Some Windows use something like $ENV{'HOME'}
2823             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2824             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2825 0         0 }
2826              
2827             return undef;
2828             }
2829              
2830             #
2831             # via File::HomeDir::Unix 1.00
2832 0     0 0 0 #
2833             sub my_home {
2834 0 0 0     0 my $home;
    0 0        
2835 0         0  
2836             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2837             $home = $ENV{'HOME'};
2838             }
2839              
2840             # This is from the original code, but I'm guessing
2841 0         0 # it means "login directory" and exists on some Unixes.
2842             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2843             $home = $ENV{'LOGDIR'};
2844             }
2845              
2846             ### More-desperate methods
2847              
2848 0         0 # Light desperation on any (Unixish) platform
2849             else {
2850             $home = CORE::eval q{ (getpwuid($<))[7] };
2851             }
2852              
2853 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2854 0         0 # For example, "nobody"-like users might use /nonexistant
2855             if (defined $home and ! -d($home)) {
2856 0         0 $home = undef;
2857             }
2858             return $home;
2859             }
2860              
2861             #
2862             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2863 0 0   0 0 0 #
2864 0 0 0     0 sub Eeuctw::PREMATCH {
2865 0         0 if (defined($&)) {
2866             if (defined($1) and (CORE::substr($&,-CORE::length($1),CORE::length($1)) eq $1)) {
2867             return CORE::substr($&,0,CORE::length($&)-CORE::length($1));
2868 0         0 }
2869             else {
2870             croak 'Use of "$`", $PREMATCH, and ${^PREMATCH} need to /( capture all )/ in regexp';
2871             }
2872 0         0 }
2873             else {
2874 0         0 return '';
2875             }
2876             return $`;
2877             }
2878              
2879             #
2880             # ${^MATCH}, $MATCH, $& the string that matched
2881 0 0   0 0 0 #
2882 0 0       0 sub Eeuctw::MATCH {
2883 0         0 if (defined($&)) {
2884             if (defined($1)) {
2885             return $1;
2886 0         0 }
2887             else {
2888             croak 'Use of "$&", $MATCH, and ${^MATCH} need to /( capture all )/ in regexp';
2889             }
2890 0         0 }
2891             else {
2892 0         0 return '';
2893             }
2894             return $&;
2895             }
2896              
2897             #
2898             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2899 0     0 0 0 #
2900             sub Eeuctw::POSTMATCH {
2901             return $';
2902             }
2903              
2904             #
2905             # EUC-TW character to order (with parameter)
2906             #
2907 0 0   0 1 0 sub EUCTW::ord(;$) {
2908              
2909 0 0       0 local $_ = shift if @_;
2910 0         0  
2911 0         0 if (/\A ($q_char) /oxms) {
2912 0         0 my @ord = unpack 'C*', $1;
2913 0         0 my $ord = 0;
2914             while (my $o = shift @ord) {
2915 0         0 $ord = $ord * 0x100 + $o;
2916             }
2917             return $ord;
2918 0         0 }
2919             else {
2920             return CORE::ord $_;
2921             }
2922             }
2923              
2924             #
2925             # EUC-TW character to order (without parameter)
2926             #
2927 0 0   0 0 0 sub EUCTW::ord_() {
2928 0         0  
2929 0         0 if (/\A ($q_char) /oxms) {
2930 0         0 my @ord = unpack 'C*', $1;
2931 0         0 my $ord = 0;
2932             while (my $o = shift @ord) {
2933 0         0 $ord = $ord * 0x100 + $o;
2934             }
2935             return $ord;
2936 0         0 }
2937             else {
2938             return CORE::ord $_;
2939             }
2940             }
2941              
2942             #
2943             # EUC-TW reverse
2944             #
2945 0 0   0 0 0 sub EUCTW::reverse(@) {
2946 0         0  
2947             if (wantarray) {
2948             return CORE::reverse @_;
2949             }
2950             else {
2951              
2952             # One of us once cornered Larry in an elevator and asked him what
2953             # problem he was solving with this, but he looked as far off into
2954             # the distance as he could in an elevator and said, "It seemed like
2955 0         0 # a good idea at the time."
2956              
2957             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2958             }
2959             }
2960              
2961             #
2962             # EUC-TW getc (with parameter, without parameter)
2963             #
2964 0     0 0 0 sub EUCTW::getc(;*@) {
2965 0 0       0  
2966 0 0 0     0 my($package) = caller;
2967             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2968 0         0 croak 'Too many arguments for EUCTW::getc' if @_ and not wantarray;
  0         0  
2969 0         0  
2970 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2971 0         0 my $getc = '';
2972 0 0       0 for my $length ($length[0] .. $length[-1]) {
2973 0 0       0 $getc .= CORE::getc($fh);
2974 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2975             if ($getc =~ /\A ${Eeuctw::dot_s} \z/oxms) {
2976             return wantarray ? ($getc,@_) : $getc;
2977             }
2978 0 0       0 }
2979             }
2980             return wantarray ? ($getc,@_) : $getc;
2981             }
2982              
2983             #
2984             # EUC-TW length by character
2985             #
2986 0 0   0 1 0 sub EUCTW::length(;$) {
2987              
2988 0         0 local $_ = shift if @_;
2989 0         0  
2990             local @_ = /\G ($q_char) /oxmsg;
2991             return scalar @_;
2992             }
2993              
2994             #
2995             # EUC-TW substr by character
2996             #
2997             BEGIN {
2998              
2999             # P.232 The lvalue Attribute
3000             # in Chapter 6: Subroutines
3001             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3002              
3003             # P.336 The lvalue Attribute
3004             # in Chapter 7: Subroutines
3005             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3006              
3007             # P.144 8.4 Lvalue subroutines
3008             # in Chapter 8: perlsub: Perl subroutines
3009 329 50 0 329 1 226101 # 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  
3010              
3011             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
3012             # vv----------------------*******
3013             sub EUCTW::substr($$;$$) %s {
3014              
3015             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
3016              
3017             # If the substring is beyond either end of the string, substr() returns the undefined
3018             # value and produces a warning. When used as an lvalue, specifying a substring that
3019             # is entirely outside the string raises an exception.
3020             # http://perldoc.perl.org/functions/substr.html
3021              
3022             # A return with no argument returns the scalar value undef in scalar context,
3023             # an empty list () in list context, and (naturally) nothing at all in void
3024             # context.
3025              
3026             my $offset = $_[1];
3027             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
3028             return;
3029             }
3030              
3031             # substr($string,$offset,$length,$replacement)
3032             if (@_ == 4) {
3033             my(undef,undef,$length,$replacement) = @_;
3034             my $substr = join '', splice(@char, $offset, $length, $replacement);
3035             $_[0] = join '', @char;
3036              
3037             # return $substr; this doesn't work, don't say "return"
3038             $substr;
3039             }
3040              
3041             # substr($string,$offset,$length)
3042             elsif (@_ == 3) {
3043             my(undef,undef,$length) = @_;
3044             my $octet_offset = 0;
3045             my $octet_length = 0;
3046             if ($offset == 0) {
3047             $octet_offset = 0;
3048             }
3049             elsif ($offset > 0) {
3050             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
3051             }
3052             else {
3053             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
3054             }
3055             if ($length == 0) {
3056             $octet_length = 0;
3057             }
3058             elsif ($length > 0) {
3059             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
3060             }
3061             else {
3062             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
3063             }
3064             CORE::substr($_[0], $octet_offset, $octet_length);
3065             }
3066              
3067             # substr($string,$offset)
3068             else {
3069             my $octet_offset = 0;
3070             if ($offset == 0) {
3071             $octet_offset = 0;
3072             }
3073             elsif ($offset > 0) {
3074             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
3075             }
3076             else {
3077             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
3078             }
3079             CORE::substr($_[0], $octet_offset);
3080             }
3081             }
3082             END
3083             }
3084              
3085             #
3086             # EUC-TW index by character
3087             #
3088 0     0 1 0 sub EUCTW::index($$;$) {
3089 0 0       0  
3090 0         0 my $index;
3091             if (@_ == 3) {
3092             $index = Eeuctw::index($_[0], $_[1], CORE::length(EUCTW::substr($_[0], 0, $_[2])));
3093 0         0 }
3094             else {
3095             $index = Eeuctw::index($_[0], $_[1]);
3096 0 0       0 }
3097 0         0  
3098             if ($index == -1) {
3099             return -1;
3100 0         0 }
3101             else {
3102             return EUCTW::length(CORE::substr $_[0], 0, $index);
3103             }
3104             }
3105              
3106             #
3107             # EUC-TW rindex by character
3108             #
3109 0     0 1 0 sub EUCTW::rindex($$;$) {
3110 0 0       0  
3111 0         0 my $rindex;
3112             if (@_ == 3) {
3113             $rindex = Eeuctw::rindex($_[0], $_[1], CORE::length(EUCTW::substr($_[0], 0, $_[2])));
3114 0         0 }
3115             else {
3116             $rindex = Eeuctw::rindex($_[0], $_[1]);
3117 0 0       0 }
3118 0         0  
3119             if ($rindex == -1) {
3120             return -1;
3121 0         0 }
3122             else {
3123             return EUCTW::length(CORE::substr $_[0], 0, $rindex);
3124             }
3125             }
3126              
3127 329     329   7655 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  329         710  
  329         63178  
3128             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
3129             use vars qw($slash); $slash = 'm//';
3130              
3131             # ord() to ord() or EUCTW::ord()
3132             my $function_ord = 'ord';
3133              
3134             # ord to ord or EUCTW::ord_
3135             my $function_ord_ = 'ord';
3136              
3137             # reverse to reverse or EUCTW::reverse
3138             my $function_reverse = 'reverse';
3139              
3140             # getc to getc or EUCTW::getc
3141             my $function_getc = 'getc';
3142              
3143             # P.1023 Appendix W.9 Multibyte Anchoring
3144             # of ISBN 1-56592-224-7 CJKV Information Processing
3145              
3146             my $anchor = '';
3147 329     329   4594 $anchor = q{${Eeuctw::anchor}};
  329     0   2259  
  329         16085598  
3148              
3149             use vars qw($nest);
3150              
3151             # regexp of nested parens in qqXX
3152              
3153             # P.340 Matching Nested Constructs with Embedded Code
3154             # in Chapter 7: Perl
3155             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3156              
3157             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
3158             [^\x8E\xA1-\xFE\\()] |
3159             \( (?{$nest++}) |
3160             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3161             [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3162             \\ [^\x8E\xA1-\xFEc] |
3163             \\c[\x40-\x5F] |
3164             \\ [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3165             [\x00-\xFF]
3166             }xms;
3167              
3168             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
3169             [^\x8E\xA1-\xFE\\{}] |
3170             \{ (?{$nest++}) |
3171             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3172             [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3173             \\ [^\x8E\xA1-\xFEc] |
3174             \\c[\x40-\x5F] |
3175             \\ [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3176             [\x00-\xFF]
3177             }xms;
3178              
3179             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
3180             [^\x8E\xA1-\xFE\\\[\]] |
3181             \[ (?{$nest++}) |
3182             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3183             [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3184             \\ [^\x8E\xA1-\xFEc] |
3185             \\c[\x40-\x5F] |
3186             \\ [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3187             [\x00-\xFF]
3188             }xms;
3189              
3190             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
3191             [^\x8E\xA1-\xFE\\<>] |
3192             \< (?{$nest++}) |
3193             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3194             [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3195             \\ [^\x8E\xA1-\xFEc] |
3196             \\c[\x40-\x5F] |
3197             \\ [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3198             [\x00-\xFF]
3199             }xms;
3200              
3201             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
3202             (?: ::)? (?:
3203             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
3204             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
3205             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
3206             ))
3207             }xms;
3208              
3209             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
3210             (?: ::)? (?:
3211             (?>[0-9]+) |
3212             [^\x8E\xA1-\xFEa-zA-Z_0-9\[\]] |
3213             ^[A-Z] |
3214             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
3215             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
3216             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
3217             ))
3218             }xms;
3219              
3220             my $qq_substr = qr{(?> Char::substr | EUCTW::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
3221             }xms;
3222              
3223             # regexp of nested parens in qXX
3224             my $q_paren = qr{(?{local $nest=0}) (?>(?:
3225             [^\x8E\xA1-\xFE()] |
3226             [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3227             \( (?{$nest++}) |
3228             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3229             [\x00-\xFF]
3230             }xms;
3231              
3232             my $q_brace = qr{(?{local $nest=0}) (?>(?:
3233             [^\x8E\xA1-\xFE\{\}] |
3234             [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3235             \{ (?{$nest++}) |
3236             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3237             [\x00-\xFF]
3238             }xms;
3239              
3240             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
3241             [^\x8E\xA1-\xFE\[\]] |
3242             [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3243             \[ (?{$nest++}) |
3244             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3245             [\x00-\xFF]
3246             }xms;
3247              
3248             my $q_angle = qr{(?{local $nest=0}) (?>(?:
3249             [^\x8E\xA1-\xFE<>] |
3250             [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
3251             \< (?{$nest++}) |
3252             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3253             [\x00-\xFF]
3254             }xms;
3255              
3256             my $matched = '';
3257             my $s_matched = '';
3258             $matched = q{$Eeuctw::matched};
3259             $s_matched = q{ Eeuctw::s_matched();};
3260              
3261             my $tr_variable = ''; # variable of tr///
3262             my $sub_variable = ''; # variable of s///
3263             my $bind_operator = ''; # =~ or !~
3264              
3265             my @heredoc = (); # here document
3266             my @heredoc_delimiter = ();
3267             my $here_script = ''; # here script
3268              
3269             #
3270             # escape EUC-TW script
3271 0 50   329 0 0 #
3272             sub EUCTW::escape(;$) {
3273             local($_) = $_[0] if @_;
3274              
3275             # P.359 The Study Function
3276             # in Chapter 7: Perl
3277 329         1134 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3278              
3279             study $_; # Yes, I studied study yesterday.
3280              
3281             # while all script
3282              
3283             # 6.14. Matching from Where the Last Pattern Left Off
3284             # in Chapter 6. Pattern Matching
3285             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3286             # (and so on)
3287              
3288             # one member of Tag-team
3289             #
3290             # P.128 Start of match (or end of previous match): \G
3291             # P.130 Advanced Use of \G with Perl
3292             # in Chapter 3: Overview of Regular Expression Features and Flavors
3293             # P.255 Use leading anchors
3294             # P.256 Expose ^ and \G at the front expressions
3295             # in Chapter 6: Crafting an Efficient Expression
3296             # P.315 "Tag-team" matching with /gc
3297             # in Chapter 7: Perl
3298 329         666 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3299 329         820  
3300 329         1268 my $e_script = '';
3301             while (not /\G \z/oxgc) { # member
3302             $e_script .= EUCTW::escape_token();
3303 131742         230027 }
3304              
3305             return $e_script;
3306             }
3307              
3308             #
3309             # escape EUC-TW token of script
3310             #
3311             sub EUCTW::escape_token {
3312              
3313 329     131742 0 5012 # \n output here document
3314              
3315             my $ignore_modules = join('|', qw(
3316             utf8
3317             bytes
3318             charnames
3319             I18N::Japanese
3320             I18N::Collate
3321             I18N::JExt
3322             File::DosGlob
3323             Wild
3324             Wildcard
3325             Japanese
3326             ));
3327              
3328             # another member of Tag-team
3329             #
3330             # P.315 "Tag-team" matching with /gc
3331             # in Chapter 7: Perl
3332 131742 100 100     161555 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    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          
3333 131742         6832639  
3334 22438 100       28423 if (/\G ( \n ) /oxgc) { # another member (and so on)
3335 22438         42824 my $heredoc = '';
3336             if (scalar(@heredoc_delimiter) >= 1) {
3337 191         245 $slash = 'm//';
3338 191         384  
3339             $heredoc = join '', @heredoc;
3340             @heredoc = ();
3341 191         669  
3342 191         407 # skip here document
3343             for my $heredoc_delimiter (@heredoc_delimiter) {
3344 199         1414 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3345             }
3346 191         471 @heredoc_delimiter = ();
3347              
3348 191         259 $here_script = '';
3349             }
3350             return "\n" . $heredoc;
3351             }
3352 22438         67713  
3353             # ignore space, comment
3354             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3355              
3356             # if (, elsif (, unless (, while (, until (, given (, and when (
3357              
3358             # given, when
3359              
3360             # P.225 The given Statement
3361             # in Chapter 15: Smart Matching and given-when
3362             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3363              
3364             # P.133 The given Statement
3365             # in Chapter 4: Statements and Declarations
3366             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3367 31196         107250  
3368 2628         3968 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3369             $slash = 'm//';
3370             return $1;
3371             }
3372              
3373             # scalar variable ($scalar = ...) =~ tr///;
3374             # scalar variable ($scalar = ...) =~ s///;
3375              
3376             # state
3377              
3378             # P.68 Persistent, Private Variables
3379             # in Chapter 4: Subroutines
3380             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3381              
3382             # P.160 Persistent Lexically Scoped Variables: state
3383             # in Chapter 4: Statements and Declarations
3384             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3385              
3386             # (and so on)
3387 2628         9381  
3388             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3389 145 50       369 my $e_string = e_string($1);
    50          
3390 145         6083  
3391 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3392 0         0 $tr_variable = $e_string . e_string($1);
3393 0         0 $bind_operator = $2;
3394             $slash = 'm//';
3395             return '';
3396 0         0 }
3397 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3398 0         0 $sub_variable = $e_string . e_string($1);
3399 0         0 $bind_operator = $2;
3400             $slash = 'm//';
3401             return '';
3402 0         0 }
3403 145         288 else {
3404             $slash = 'div';
3405             return $e_string;
3406             }
3407             }
3408              
3409 145         545 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eeuctw::PREMATCH()
3410 4         10 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3411             $slash = 'div';
3412             return q{Eeuctw::PREMATCH()};
3413             }
3414              
3415 4         13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eeuctw::MATCH()
3416 28         58 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3417             $slash = 'div';
3418             return q{Eeuctw::MATCH()};
3419             }
3420              
3421 28         75 # $', ${'} --> $', ${'}
3422 1         3 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3423             $slash = 'div';
3424             return $1;
3425             }
3426              
3427 1         3 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eeuctw::POSTMATCH()
3428 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3429             $slash = 'div';
3430             return q{Eeuctw::POSTMATCH()};
3431             }
3432              
3433             # scalar variable $scalar =~ tr///;
3434             # scalar variable $scalar =~ s///;
3435             # substr() =~ tr///;
3436 3         10 # substr() =~ s///;
3437             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3438 2439 100       5626 my $scalar = e_string($1);
    100          
3439 2439         9823  
3440 9         15 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3441 9         18 $tr_variable = $scalar;
3442 9         14 $bind_operator = $1;
3443             $slash = 'm//';
3444             return '';
3445 9         26 }
3446 119         234 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3447 119         255 $sub_variable = $scalar;
3448 119         182 $bind_operator = $1;
3449             $slash = 'm//';
3450             return '';
3451 119         336 }
3452 2311         3420 else {
3453             $slash = 'div';
3454             return $scalar;
3455             }
3456             }
3457              
3458 2311         10170 # end of statement
3459             elsif (/\G ( [,;] ) /oxgc) {
3460             $slash = 'm//';
3461 8438         13337  
3462             # clear tr/// variable
3463             $tr_variable = '';
3464 8438         9962  
3465             # clear s/// variable
3466 8438         11192 $sub_variable = '';
3467              
3468 8438         10745 $bind_operator = '';
3469              
3470             return $1;
3471             }
3472              
3473 8438         30141 # bareword
3474             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3475             return $1;
3476             }
3477              
3478 0         0 # $0 --> $0
3479 2         6 elsif (/\G ( \$ 0 ) /oxmsgc) {
3480             $slash = 'div';
3481             return $1;
3482 2         117 }
3483 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3484             $slash = 'div';
3485             return $1;
3486             }
3487              
3488 0         0 # $$ --> $$
3489 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3490             $slash = 'div';
3491             return $1;
3492             }
3493              
3494             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3495 1         3 # $1, $2, $3 --> $1, $2, $3 otherwise
3496 129         222 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3497             $slash = 'div';
3498             return e_capture($1);
3499 129         281 }
3500 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3501             $slash = 'div';
3502             return e_capture($1);
3503             }
3504              
3505 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3506 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3507             $slash = 'div';
3508             return e_capture($1.'->'.$2);
3509             }
3510              
3511 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3512 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3513             $slash = 'div';
3514             return e_capture($1.'->'.$2);
3515             }
3516              
3517 0         0 # $$foo
3518 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3519             $slash = 'div';
3520             return e_capture($1);
3521             }
3522              
3523 0         0 # ${ foo }
3524 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3525             $slash = 'div';
3526             return '${' . $1 . '}';
3527             }
3528              
3529 0         0 # ${ ... }
3530 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3531             $slash = 'div';
3532             return e_capture($1);
3533             }
3534              
3535             # variable or function
3536 0         0 # $ @ % & * $ #
3537 149         251 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) {
3538             $slash = 'div';
3539             return $1;
3540             }
3541             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3542 149         565 # $ @ # \ ' " / ? ( ) [ ] < >
3543 91         187 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3544             $slash = 'div';
3545             return $1;
3546             }
3547              
3548 91         325 # while ()
3549             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3550             return $1;
3551             }
3552              
3553             # while () --- glob
3554              
3555             # avoid "Error: Runtime exception" of perl version 5.005_03
3556 0         0  
3557             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^\x8E\xA1-\xFE>\0\a\e\f\n\r\t]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])+?) > (?>\s*) \) \b /oxgc) {
3558             return 'while ($_ = Eeuctw::glob("' . $1 . '"))';
3559             }
3560              
3561 0         0 # while (glob)
3562             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3563             return 'while ($_ = Eeuctw::glob_)';
3564             }
3565              
3566 0         0 # while (glob(WILDCARD))
3567             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3568             return 'while ($_ = Eeuctw::glob';
3569             }
3570 0         0  
  425         1112  
3571             # doit if, doit unless, doit while, doit until, doit for, doit when
3572             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3573 425         1635  
  19         40  
3574 19         81 # subroutines of package Eeuctw
  0         0  
3575 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         21  
3576 13         37 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3577 0         0 elsif (/\G \b EUCTW::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         253  
3578 114         323 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         4  
3579 2         7 elsif (/\G \b EUCTW::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval EUCTW::escape'; }
  2         4  
3580 2         7 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
3581 2         5 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eeuctw::chop'; }
  0         0  
3582 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         5  
3583 2         5 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  2         3  
3584 2         6 elsif (/\G \b EUCTW::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'EUCTW::index'; }
  2         4  
3585 2         5 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eeuctw::index'; }
  0         0  
3586 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         4  
3587 2         13 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  2         4  
3588 2         5 elsif (/\G \b EUCTW::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'EUCTW::rindex'; }
  1         2  
3589 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eeuctw::rindex'; }
  0         0  
3590 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eeuctw::lc'; }
  0         0  
3591 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eeuctw::lcfirst'; }
  0         0  
3592 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eeuctw::uc'; }
  3         6  
3593             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eeuctw::ucfirst'; }
3594             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eeuctw::fc'; }
3595 3         9  
  0         0  
3596 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3597 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3598 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3599 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3600 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3601 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3602             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3603 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  
3604 0         0  
  0         0  
3605 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3606 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3607 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3608 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3609 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3610             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3611             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3612 0         0  
  0         0  
3613 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3614 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3615 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3616             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3617 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         4  
3618 2         6  
  2         4  
3619 2         8 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         62  
3620 36         104 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3621 2         7 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eeuctw::chr'; }
  2         4  
3622 2         7 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3623 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3624 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eeuctw::glob'; }
  0         0  
3625 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eeuctw::lc_'; }
  0         0  
3626 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eeuctw::lcfirst_'; }
  0         0  
3627 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eeuctw::uc_'; }
  0         0  
3628 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eeuctw::ucfirst_'; }
  0         0  
3629             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eeuctw::fc_'; }
3630 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3631 0         0  
  0         0  
3632 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3633 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3634 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eeuctw::chr_'; }
  2         6  
3635 2         8 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3636 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  4         7  
3637 4         15 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eeuctw::glob_'; }
  8         20  
3638             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3639             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3640 8         32 # split
3641             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3642 186         376 $slash = 'm//';
3643 186         289  
3644 186         676 my $e = '';
3645             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3646             $e .= $1;
3647             }
3648 183 100       747  
  186 100       13141  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3649             # end of split
3650             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Eeuctw::split' . $e; }
3651 3         14  
3652             # split scalar value
3653             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Eeuctw::split' . $e . e_string($1); }
3654 1         6  
3655 0         0 # split literal space
3656 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Eeuctw::split' . $e . qq {qq$1 $2}; }
3657 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Eeuctw::split' . $e . qq{$1qq$2 $3}; }
3658 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Eeuctw::split' . $e . qq{$1qq$2 $3}; }
3659 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Eeuctw::split' . $e . qq{$1qq$2 $3}; }
3660 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Eeuctw::split' . $e . qq{$1qq$2 $3}; }
3661 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Eeuctw::split' . $e . qq{$1qq$2 $3}; }
3662 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Eeuctw::split' . $e . qq {q$1 $2}; }
3663 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Eeuctw::split' . $e . qq {$1q$2 $3}; }
3664 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Eeuctw::split' . $e . qq {$1q$2 $3}; }
3665 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Eeuctw::split' . $e . qq {$1q$2 $3}; }
3666 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Eeuctw::split' . $e . qq {$1q$2 $3}; }
3667 13         65 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Eeuctw::split' . $e . qq {$1q$2 $3}; }
3668             elsif (/\G ' [ ] ' /oxgc) { return 'Eeuctw::split' . $e . qq {' '}; }
3669             elsif (/\G " [ ] " /oxgc) { return 'Eeuctw::split' . $e . qq {" "}; }
3670              
3671 2 0       11 # split qq//
  0         0  
3672             elsif (/\G \b (qq) \b /oxgc) {
3673 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3674 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3675 0         0 while (not /\G \z/oxgc) {
3676 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3677 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3678 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3679 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3680 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3681             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3682 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3683             }
3684             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3685             }
3686             }
3687              
3688 0 50       0 # split qr//
  36         704  
3689             elsif (/\G \b (qr) \b /oxgc) {
3690 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3691 36 50       312 else {
  36 50       6283  
    50          
    50          
    50          
    100          
    50          
    50          
3692 0         0 while (not /\G \z/oxgc) {
3693 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3694 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3695 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3696 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3697 12         63 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3698 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3699             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3700 24         130 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3701             }
3702             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3703             }
3704             }
3705              
3706 0 0       0 # split q//
  0         0  
3707             elsif (/\G \b (q) \b /oxgc) {
3708 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3709 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3710 0         0 while (not /\G \z/oxgc) {
3711 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3712 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3713 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3714 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3715 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3716             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3717 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3718             }
3719             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3720             }
3721             }
3722              
3723 0 50       0 # split m//
  48         1118  
3724             elsif (/\G \b (m) \b /oxgc) {
3725 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3726 48 50       173 else {
  48 50       6356  
    50          
    50          
    50          
    100          
    50          
    50          
3727 0         0 while (not /\G \z/oxgc) {
3728 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3729 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3730 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3731 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3732 12         50 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3733 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3734             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3735 36         257 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3736             }
3737             die __FILE__, ": Search pattern not terminated\n";
3738             }
3739             }
3740              
3741 0         0 # split ''
3742 0         0 elsif (/\G (\') /oxgc) {
3743 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3744 0         0 while (not /\G \z/oxgc) {
3745 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3746 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3747             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3748 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3749             }
3750             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3751             }
3752              
3753 0         0 # split ""
3754 0         0 elsif (/\G (\") /oxgc) {
3755 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3756 0         0 while (not /\G \z/oxgc) {
3757 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3758 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3759             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3760 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3761             }
3762             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3763             }
3764              
3765 0         0 # split //
3766 83         204 elsif (/\G (\/) /oxgc) {
3767 83 50       275 my $regexp = '';
  470 50       2682  
    100          
    50          
3768 0         0 while (not /\G \z/oxgc) {
3769 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3770 83         454 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3771             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3772 387         916 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3773             }
3774             die __FILE__, ": Search pattern not terminated\n";
3775             }
3776             }
3777              
3778             # tr/// or y///
3779              
3780             # about [cdsrbB]* (/B modifier)
3781             #
3782             # P.559 appendix C
3783             # of ISBN 4-89052-384-7 Programming perl
3784             # (Japanese title is: Perl puroguramingu)
3785 0         0  
3786             elsif (/\G \b ( tr | y ) \b /oxgc) {
3787             my $ope = $1;
3788 11 50       25  
3789 11         178 # $1 $2 $3 $4 $5 $6
3790 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3791             my @tr = ($tr_variable,$2);
3792             return e_tr(@tr,'',$4,$6);
3793 0         0 }
3794 11         23 else {
3795 11 50       32 my $e = '';
  11 50       961  
    50          
    50          
    50          
    50          
3796             while (not /\G \z/oxgc) {
3797 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3798 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3799 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3800 0         0 while (not /\G \z/oxgc) {
3801 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3802 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3803 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3804 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3805             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3806 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3807             }
3808             die __FILE__, ": Transliteration replacement not terminated\n";
3809 0         0 }
3810 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3811 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3812 0         0 while (not /\G \z/oxgc) {
3813 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3814 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3815 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3816 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3817             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3818 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3819             }
3820             die __FILE__, ": Transliteration replacement not terminated\n";
3821 0         0 }
3822 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3823 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3824 0         0 while (not /\G \z/oxgc) {
3825 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3826 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3827 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3828 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3829             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3830 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3831             }
3832             die __FILE__, ": Transliteration replacement not terminated\n";
3833 0         0 }
3834 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3835 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3836 0         0 while (not /\G \z/oxgc) {
3837 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3838 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3839 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3840 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3841             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3842 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3843             }
3844             die __FILE__, ": Transliteration replacement not terminated\n";
3845             }
3846 0         0 # $1 $2 $3 $4 $5 $6
3847 11         44 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3848             my @tr = ($tr_variable,$2);
3849             return e_tr(@tr,'',$4,$6);
3850 11         36 }
3851             }
3852             die __FILE__, ": Transliteration pattern not terminated\n";
3853             }
3854             }
3855              
3856 0         0 # qq//
3857             elsif (/\G \b (qq) \b /oxgc) {
3858             my $ope = $1;
3859 4209 100       21907  
3860 4209         8452 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3861 40         55 if (/\G (\#) /oxgc) { # qq# #
3862 40 100       77 my $qq_string = '';
  1948 50       5681  
    100          
    50          
3863 80         144 while (not /\G \z/oxgc) {
3864 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3865 40         78 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3866             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3867 1828         3530 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3868             }
3869             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3870             }
3871 0         0  
3872 4169         5911 else {
3873 4169 50       10852 my $e = '';
  4169 50       16959  
    100          
    50          
    100          
    50          
3874             while (not /\G \z/oxgc) {
3875             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3876              
3877 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3878 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3879 0         0 my $qq_string = '';
3880 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3881 0         0 while (not /\G \z/oxgc) {
3882 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3883             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3884 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3885 0         0 elsif (/\G (\)) /oxgc) {
3886             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3887 0         0 else { $qq_string .= $1; }
3888             }
3889 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3890             }
3891             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3892             }
3893              
3894 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3895 4111         6922 elsif (/\G (\{) /oxgc) { # qq { }
3896 4111         6922 my $qq_string = '';
3897 4111 100       9114 local $nest = 1;
  172633 50       610209  
    100          
    100          
    50          
3898 708         1819 while (not /\G \z/oxgc) {
3899 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1384         2157  
3900             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3901 1384 100       2301 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  5495         8847  
3902 4111         8433 elsif (/\G (\}) /oxgc) {
3903             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3904 1384         2821 else { $qq_string .= $1; }
3905             }
3906 165046         347147 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3907             }
3908             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3909             }
3910              
3911 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3912 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3913 0         0 my $qq_string = '';
3914 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3915 0         0 while (not /\G \z/oxgc) {
3916 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3917             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3918 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3919 0         0 elsif (/\G (\]) /oxgc) {
3920             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3921 0         0 else { $qq_string .= $1; }
3922             }
3923 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3924             }
3925             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3926             }
3927              
3928 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3929 38         62 elsif (/\G (\<) /oxgc) { # qq < >
3930 38         63 my $qq_string = '';
3931 38 100       122 local $nest = 1;
  1418 50       5660  
    50          
    100          
    50          
3932 22         118 while (not /\G \z/oxgc) {
3933 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3934             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3935 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  38         85  
3936 38         162 elsif (/\G (\>) /oxgc) {
3937             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3938 0         0 else { $qq_string .= $1; }
3939             }
3940 1358         2757 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3941             }
3942             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3943             }
3944              
3945 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3946 20         30 elsif (/\G (\S) /oxgc) { # qq * *
3947 20         22 my $delimiter = $1;
3948 20 50       40 my $qq_string = '';
  840 50       2253  
    100          
    50          
3949 0         0 while (not /\G \z/oxgc) {
3950 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3951 20         37 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3952             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3953 820         1503 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3954             }
3955             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3956 0         0 }
3957             }
3958             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3959             }
3960             }
3961              
3962 0         0 # qr//
3963 60 50       133 elsif (/\G \b (qr) \b /oxgc) {
3964 60         576 my $ope = $1;
3965             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3966             return e_qr($ope,$1,$3,$2,$4);
3967 0         0 }
3968 60         88 else {
3969 60 50       147 my $e = '';
  60 50       3969  
    100          
    50          
    50          
    100          
    50          
    50          
3970 0         0 while (not /\G \z/oxgc) {
3971 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3972 1         5 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3973 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3974 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3975 14         45 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3976 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3977             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3978 45         137 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3979             }
3980             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3981             }
3982             }
3983              
3984 0         0 # qw//
3985 34 50       93 elsif (/\G \b (qw) \b /oxgc) {
3986 34         98 my $ope = $1;
3987             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3988             return e_qw($ope,$1,$3,$2);
3989 0         0 }
3990 34         60 else {
3991 34 50       119 my $e = '';
  34 50       208  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3992             while (not /\G \z/oxgc) {
3993 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3994 34         114  
3995             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3996 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3997 0         0  
3998             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3999 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
4000 0         0  
4001             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
4002 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
4003 0         0  
4004             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
4005 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
4006 0         0  
4007             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
4008 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
4009             }
4010             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4011             }
4012             }
4013              
4014 0         0 # qx//
4015 2 50       5 elsif (/\G \b (qx) \b /oxgc) {
4016 2         38 my $ope = $1;
4017             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4018             return e_qq($ope,$1,$3,$2);
4019 0         0 }
4020 2         12 else {
4021 2 50       8 my $e = '';
  2 50       140  
    50          
    0          
    0          
    0          
    0          
4022 0         0 while (not /\G \z/oxgc) {
4023 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
4024 2         8 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
4025 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
4026 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
4027 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
4028             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
4029 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
4030             }
4031             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4032             }
4033             }
4034              
4035 0         0 # q//
4036             elsif (/\G \b (q) \b /oxgc) {
4037             my $ope = $1;
4038              
4039             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
4040              
4041             # avoid "Error: Runtime exception" of perl version 5.005_03
4042 550 50       1501 # (and so on)
4043 550         1552  
4044 0         0 if (/\G (\#) /oxgc) { # q# #
4045 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4046 0         0 while (not /\G \z/oxgc) {
4047 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4048 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
4049             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
4050 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4051             }
4052             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4053             }
4054 0         0  
4055 550         959 else {
4056 550 50       1870 my $e = '';
  550 50       3334  
    100          
    50          
    100          
    50          
4057             while (not /\G \z/oxgc) {
4058             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
4059              
4060 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
4061 0         0 elsif (/\G (\() /oxgc) { # q ( )
4062 0         0 my $q_string = '';
4063 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
4064 0         0 while (not /\G \z/oxgc) {
4065 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4066 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
4067             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
4068 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
4069 0         0 elsif (/\G (\)) /oxgc) {
4070             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
4071 0         0 else { $q_string .= $1; }
4072             }
4073 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4074             }
4075             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4076             }
4077              
4078 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
4079 544         958 elsif (/\G (\{) /oxgc) { # q { }
4080 544         935 my $q_string = '';
4081 544 50       1682 local $nest = 1;
  8103 50       38442  
    50          
    100          
    100          
    50          
4082 0         0 while (not /\G \z/oxgc) {
4083 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4084 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  114         182  
4085             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
4086 114 100       214 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  658         1494  
4087 544         1622 elsif (/\G (\}) /oxgc) {
4088             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
4089 114         280 else { $q_string .= $1; }
4090             }
4091 7331         14958 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4092             }
4093             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4094             }
4095              
4096 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
4097 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
4098 0         0 my $q_string = '';
4099 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
4100 0         0 while (not /\G \z/oxgc) {
4101 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4102 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
4103             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
4104 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
4105 0         0 elsif (/\G (\]) /oxgc) {
4106             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
4107 0         0 else { $q_string .= $1; }
4108             }
4109 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4110             }
4111             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4112             }
4113              
4114 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
4115 5         15 elsif (/\G (\<) /oxgc) { # q < >
4116 5         11 my $q_string = '';
4117 5 50       15 local $nest = 1;
  82 50       409  
    50          
    50          
    100          
    50          
4118 0         0 while (not /\G \z/oxgc) {
4119 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4120 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
4121             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
4122 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         14  
4123 5         13 elsif (/\G (\>) /oxgc) {
4124             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
4125 0         0 else { $q_string .= $1; }
4126             }
4127 77         156 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4128             }
4129             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4130             }
4131              
4132 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
4133 1         2 elsif (/\G (\S) /oxgc) { # q * *
4134 1         2 my $delimiter = $1;
4135 1 50       4 my $q_string = '';
  14 50       78  
    100          
    50          
4136 0         0 while (not /\G \z/oxgc) {
4137 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4138 1         2 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
4139             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
4140 13         27 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4141             }
4142             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4143 0         0 }
4144             }
4145             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4146             }
4147             }
4148              
4149 0         0 # m//
4150 305 50       734 elsif (/\G \b (m) \b /oxgc) {
4151 305         2492 my $ope = $1;
4152             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
4153             return e_qr($ope,$1,$3,$2,$4);
4154 0         0 }
4155 305         532 else {
4156 305 50       863 my $e = '';
  305 50       35924  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
4157 0         0 while (not /\G \z/oxgc) {
4158 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
4159 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
4160 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
4161 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
4162 30         121 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
4163 25         91 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
4164 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
4165             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
4166 250         1020 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
4167             }
4168             die __FILE__, ": Search pattern not terminated\n";
4169             }
4170             }
4171              
4172             # s///
4173              
4174             # about [cegimosxpradlunbB]* (/cg modifier)
4175             #
4176             # P.67 Pattern-Matching Operators
4177             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
4178 0         0  
4179             elsif (/\G \b (s) \b /oxgc) {
4180             my $ope = $1;
4181 156 100       416  
4182 156         4574 # $1 $2 $3 $4 $5 $6
4183             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
4184             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4185 1         5 }
4186 155         331 else {
4187 155 50       519 my $e = '';
  155 50       33032  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
4188             while (not /\G \z/oxgc) {
4189 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
4190 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
4191 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4192             while (not /\G \z/oxgc) {
4193 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
4194 0         0 # $1 $2 $3 $4
4195 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4196 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4197 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4198 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4199 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4200 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4201 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4202             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4203 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4204             }
4205             die __FILE__, ": Substitution replacement not terminated\n";
4206 0         0 }
4207 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
4208 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4209             while (not /\G \z/oxgc) {
4210 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
4211 0         0 # $1 $2 $3 $4
4212 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4213 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4214 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4215 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4216 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4217 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4218 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4219             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4220 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4221             }
4222             die __FILE__, ": Substitution replacement not terminated\n";
4223 0         0 }
4224 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
4225 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4226             while (not /\G \z/oxgc) {
4227 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
4228 0         0 # $1 $2 $3 $4
4229 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4230 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4231 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4232 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4233 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4234             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4235 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4236             }
4237             die __FILE__, ": Substitution replacement not terminated\n";
4238 0         0 }
4239 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
4240 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4241             while (not /\G \z/oxgc) {
4242 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
4243 0         0 # $1 $2 $3 $4
4244 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4245 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4246 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4247 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4248 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4249 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4250 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4251             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4252 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4253             }
4254             die __FILE__, ": Substitution replacement not terminated\n";
4255             }
4256 0         0 # $1 $2 $3 $4 $5 $6
4257             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
4258             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4259             }
4260 34         132 # $1 $2 $3 $4 $5 $6
4261             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4262             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
4263             }
4264 2         13 # $1 $2 $3 $4 $5 $6
4265             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4266             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4267             }
4268 0         0 # $1 $2 $3 $4 $5 $6
4269             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4270             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4271 119         588 }
4272             }
4273             die __FILE__, ": Substitution pattern not terminated\n";
4274             }
4275             }
4276 0         0  
4277 0         0 # require ignore module
4278 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4279             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x8E\xA1-\xFE#]) /oxmsgc) { return "# require$1\n$2"; }
4280             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4281 0         0  
4282 66         628 # use strict; --> use strict; no strict qw(refs);
4283 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4284             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^\x8E\xA1-\xFE#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4285             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4286              
4287 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4288 3         35 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4289             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4290             return "use $1; no strict qw(refs);";
4291 0         0 }
4292             else {
4293             return "use $1;";
4294             }
4295 3 0 0     17 }
      0        
4296 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4297             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4298             return "use $1; no strict qw(refs);";
4299 0         0 }
4300             else {
4301             return "use $1;";
4302             }
4303             }
4304 0         0  
4305 2         13 # ignore use module
4306 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4307             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x8E\xA1-\xFE#]) /oxmsgc) { return "# use$1\n$2"; }
4308             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4309 0         0  
4310 0         0 # ignore no module
4311 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4312             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x8E\xA1-\xFE#]) /oxmsgc) { return "# no$1\n$2"; }
4313             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4314 0         0  
4315             # use else
4316             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4317 0         0  
4318             # use else
4319             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4320              
4321 2         7 # ''
4322 1850         4060 elsif (/\G (?
4323 1850 100       5615 my $q_string = '';
  11488 100       44062  
    100          
    50          
4324 4         11 while (not /\G \z/oxgc) {
4325 48         217 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4326 1850         4922 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4327             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4328 9586         22313 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4329             }
4330             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4331             }
4332              
4333 0         0 # ""
4334 2669         5720 elsif (/\G (\") /oxgc) {
4335 2669 100       7538 my $qq_string = '';
  50532 100       158093  
    100          
    50          
4336 109         280 while (not /\G \z/oxgc) {
4337 12         24 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4338 2669         6100 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4339             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4340 47742         133346 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4341             }
4342             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4343             }
4344              
4345 0         0 # ``
4346 1         3 elsif (/\G (\`) /oxgc) {
4347 1 50       4 my $qx_string = '';
  19 50       80  
    100          
    50          
4348 0         0 while (not /\G \z/oxgc) {
4349 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4350 1         3 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4351             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4352 18         36 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4353             }
4354             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4355             }
4356              
4357 0         0 # // --- not divide operator (num / num), not defined-or
4358 1070         2808 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4359 1070 100       3121 my $regexp = '';
  10084 50       36278  
    100          
    50          
4360 1         4 while (not /\G \z/oxgc) {
4361 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4362 1070         2983 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4363             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4364 9013         20861 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4365             }
4366             die __FILE__, ": Search pattern not terminated\n";
4367             }
4368              
4369 0         0 # ?? --- not conditional operator (condition ? then : else)
4370 30         106 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4371 30 50       93 my $regexp = '';
  122 50       586  
    100          
    50          
4372 0         0 while (not /\G \z/oxgc) {
4373 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4374 30         78 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4375             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4376 92         202 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4377             }
4378             die __FILE__, ": Search pattern not terminated\n";
4379             }
4380 0         0  
  0         0  
4381             # <<>> (a safer ARGV)
4382             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4383 0         0  
  0         0  
4384             # << (bit shift) --- not here document
4385             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4386              
4387 0         0 # <<~'HEREDOC'
4388 6         8 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4389 6         25 $slash = 'm//';
4390             my $here_quote = $1;
4391             my $delimiter = $2;
4392 6 50       10  
4393 6         13 # get here document
4394 6         39 if ($here_script eq '') {
4395             $here_script = CORE::substr $_, pos $_;
4396 6 50       31 $here_script =~ s/.*?\n//oxm;
4397 6         56 }
4398 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4399 6         10 my $heredoc = $1;
4400 6         52 my $indent = $2;
4401 6         20 $heredoc =~ s{^$indent}{}msg; # no /ox
4402             push @heredoc, $heredoc . qq{\n$delimiter\n};
4403             push @heredoc_delimiter, qq{\\s*$delimiter};
4404 6         12 }
4405             else {
4406 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4407             }
4408             return qq{<<'$delimiter'};
4409             }
4410              
4411             # <<~\HEREDOC
4412              
4413             # P.66 2.6.6. "Here" Documents
4414             # in Chapter 2: Bits and Pieces
4415             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4416              
4417             # P.73 "Here" Documents
4418             # in Chapter 2: Bits and Pieces
4419             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4420 6         24  
4421 3         7 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4422 3         8 $slash = 'm//';
4423             my $here_quote = $1;
4424             my $delimiter = $2;
4425 3 50       6  
4426 3         7 # get here document
4427 3         12 if ($here_script eq '') {
4428             $here_script = CORE::substr $_, pos $_;
4429 3 50       14 $here_script =~ s/.*?\n//oxm;
4430 3         40 }
4431 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4432 3         15 my $heredoc = $1;
4433 3         37 my $indent = $2;
4434 3         13 $heredoc =~ s{^$indent}{}msg; # no /ox
4435             push @heredoc, $heredoc . qq{\n$delimiter\n};
4436             push @heredoc_delimiter, qq{\\s*$delimiter};
4437 3         7 }
4438             else {
4439 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4440             }
4441             return qq{<<\\$delimiter};
4442             }
4443              
4444 3         13 # <<~"HEREDOC"
4445 6         12 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4446 6         11 $slash = 'm//';
4447             my $here_quote = $1;
4448             my $delimiter = $2;
4449 6 50       10  
4450 6         11 # get here document
4451 6         21 if ($here_script eq '') {
4452             $here_script = CORE::substr $_, pos $_;
4453 6 50       40 $here_script =~ s/.*?\n//oxm;
4454 6         64 }
4455 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4456 6         7 my $heredoc = $1;
4457 6         49 my $indent = $2;
4458 6         13 $heredoc =~ s{^$indent}{}msg; # no /ox
4459             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4460             push @heredoc_delimiter, qq{\\s*$delimiter};
4461 6         14 }
4462             else {
4463 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4464             }
4465             return qq{<<"$delimiter"};
4466             }
4467              
4468 6         24 # <<~HEREDOC
4469 3         6 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4470 3         7 $slash = 'm//';
4471             my $here_quote = $1;
4472             my $delimiter = $2;
4473 3 50       5  
4474 3         6 # get here document
4475 3         19 if ($here_script eq '') {
4476             $here_script = CORE::substr $_, pos $_;
4477 3 50       18 $here_script =~ s/.*?\n//oxm;
4478 3         49 }
4479 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4480 3         6 my $heredoc = $1;
4481 3         37 my $indent = $2;
4482 3         11 $heredoc =~ s{^$indent}{}msg; # no /ox
4483             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4484             push @heredoc_delimiter, qq{\\s*$delimiter};
4485 3         8 }
4486             else {
4487 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4488             }
4489             return qq{<<$delimiter};
4490             }
4491              
4492 3         14 # <<~`HEREDOC`
4493 6         13 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4494 6         10 $slash = 'm//';
4495             my $here_quote = $1;
4496             my $delimiter = $2;
4497 6 50       8  
4498 6         18 # get here document
4499 6         18 if ($here_script eq '') {
4500             $here_script = CORE::substr $_, pos $_;
4501 6 50       26 $here_script =~ s/.*?\n//oxm;
4502 6         59 }
4503 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4504 6         8 my $heredoc = $1;
4505 6         45 my $indent = $2;
4506 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
4507             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4508             push @heredoc_delimiter, qq{\\s*$delimiter};
4509 6         13 }
4510             else {
4511 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4512             }
4513             return qq{<<`$delimiter`};
4514             }
4515              
4516 6         20 # <<'HEREDOC'
4517 80         164 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4518 80         215 $slash = 'm//';
4519             my $here_quote = $1;
4520             my $delimiter = $2;
4521 80 100       124  
4522 80         152 # get here document
4523 77         445 if ($here_script eq '') {
4524             $here_script = CORE::substr $_, pos $_;
4525 77 50       553 $here_script =~ s/.*?\n//oxm;
4526 80         974 }
4527 80         274 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4528             push @heredoc, $1 . qq{\n$delimiter\n};
4529             push @heredoc_delimiter, $delimiter;
4530 80         126 }
4531             else {
4532 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4533             }
4534             return $here_quote;
4535             }
4536              
4537             # <<\HEREDOC
4538              
4539             # P.66 2.6.6. "Here" Documents
4540             # in Chapter 2: Bits and Pieces
4541             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4542              
4543             # P.73 "Here" Documents
4544             # in Chapter 2: Bits and Pieces
4545             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4546 80         595  
4547 2         5 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4548 2         5 $slash = 'm//';
4549             my $here_quote = $1;
4550             my $delimiter = $2;
4551 2 100       4  
4552 2         5 # get here document
4553 1         6 if ($here_script eq '') {
4554             $here_script = CORE::substr $_, pos $_;
4555 1 50       7 $here_script =~ s/.*?\n//oxm;
4556 2         33 }
4557 2         8 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4558             push @heredoc, $1 . qq{\n$delimiter\n};
4559             push @heredoc_delimiter, $delimiter;
4560 2         4 }
4561             else {
4562 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4563             }
4564             return $here_quote;
4565             }
4566              
4567 2         9 # <<"HEREDOC"
4568 39         97 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4569 39         91 $slash = 'm//';
4570             my $here_quote = $1;
4571             my $delimiter = $2;
4572 39 100       71  
4573 39         100 # get here document
4574 38         307 if ($here_script eq '') {
4575             $here_script = CORE::substr $_, pos $_;
4576 38 50       211 $here_script =~ s/.*?\n//oxm;
4577 39         490 }
4578 39         130 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4579             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4580             push @heredoc_delimiter, $delimiter;
4581 39         85 }
4582             else {
4583 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4584             }
4585             return $here_quote;
4586             }
4587              
4588 39         156 # <
4589 54         127 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4590 54         125 $slash = 'm//';
4591             my $here_quote = $1;
4592             my $delimiter = $2;
4593 54 100       106  
4594 54         135 # get here document
4595 51         338 if ($here_script eq '') {
4596             $here_script = CORE::substr $_, pos $_;
4597 51 50       356 $here_script =~ s/.*?\n//oxm;
4598 54         1309 }
4599 54         184 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4600             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4601             push @heredoc_delimiter, $delimiter;
4602 54         540 }
4603             else {
4604 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4605             }
4606             return $here_quote;
4607             }
4608              
4609 54         235 # <<`HEREDOC`
4610 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4611 0         0 $slash = 'm//';
4612             my $here_quote = $1;
4613             my $delimiter = $2;
4614 0 0       0  
4615 0         0 # get here document
4616 0         0 if ($here_script eq '') {
4617             $here_script = CORE::substr $_, pos $_;
4618 0 0       0 $here_script =~ s/.*?\n//oxm;
4619 0         0 }
4620 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4621             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4622             push @heredoc_delimiter, $delimiter;
4623 0         0 }
4624             else {
4625 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4626             }
4627             return $here_quote;
4628             }
4629              
4630 0         0 # <<= <=> <= < operator
4631             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4632             return $1;
4633             }
4634              
4635 13         68 #
4636             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4637             return $1;
4638             }
4639              
4640             # --- glob
4641              
4642             # avoid "Error: Runtime exception" of perl version 5.005_03
4643 0         0  
4644             elsif (/\G < ((?:[^\x8E\xA1-\xFE>\0\a\e\f\n\r\t]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF])+?) > /oxgc) {
4645             return 'Eeuctw::glob("' . $1 . '")';
4646             }
4647 0         0  
4648             # __DATA__
4649             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4650 0         0  
4651             # __END__
4652             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4653              
4654             # \cD Control-D
4655              
4656             # P.68 2.6.8. Other Literal Tokens
4657             # in Chapter 2: Bits and Pieces
4658             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4659              
4660             # P.76 Other Literal Tokens
4661             # in Chapter 2: Bits and Pieces
4662 329         2288 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4663              
4664             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4665 0         0  
4666             # \cZ Control-Z
4667             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4668              
4669             # any operator before div
4670             elsif (/\G (
4671             -- | \+\+ |
4672 0         0 [\)\}\]]
  9450         20998  
4673              
4674             ) /oxgc) { $slash = 'div'; return $1; }
4675              
4676             # yada-yada or triple-dot operator
4677             elsif (/\G (
4678 9450         57425 \.\.\.
  7         15  
4679              
4680             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4681              
4682             # any operator before m//
4683              
4684             # //, //= (defined-or)
4685              
4686             # P.164 Logical Operators
4687             # in Chapter 10: More Control Structures
4688             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4689              
4690             # P.119 C-Style Logical (Short-Circuit) Operators
4691             # in Chapter 3: Unary and Binary Operators
4692             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4693              
4694             # (and so on)
4695              
4696             # ~~
4697              
4698             # P.221 The Smart Match Operator
4699             # in Chapter 15: Smart Matching and given-when
4700             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4701              
4702             # P.112 Smartmatch Operator
4703             # in Chapter 3: Unary and Binary Operators
4704             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4705              
4706             # (and so on)
4707              
4708             elsif (/\G ((?>
4709              
4710             !~~ | !~ | != | ! |
4711             %= | % |
4712             &&= | && | &= | &\.= | &\. | & |
4713             -= | -> | - |
4714             :(?>\s*)= |
4715             : |
4716             <<>> |
4717             <<= | <=> | <= | < |
4718             == | => | =~ | = |
4719             >>= | >> | >= | > |
4720             \*\*= | \*\* | \*= | \* |
4721             \+= | \+ |
4722             \.\. | \.= | \. |
4723             \/\/= | \/\/ |
4724             \/= | \/ |
4725             \? |
4726             \\ |
4727             \^= | \^\.= | \^\. | \^ |
4728             \b x= |
4729             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4730             ~~ | ~\. | ~ |
4731             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4732             \b(?: print )\b |
4733              
4734 7         26 [,;\(\{\[]
  16286         32063  
4735              
4736             )) /oxgc) { $slash = 'm//'; return $1; }
4737 16286         92350  
  25911         49217  
4738             # other any character
4739             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4740              
4741 25911         126714 # system error
4742             else {
4743             die __FILE__, ": Oops, this shouldn't happen!\n";
4744             }
4745             }
4746              
4747 0     2626 0 0 # escape EUC-TW string
4748 2626         6066 sub e_string {
4749             my($string) = @_;
4750 2626         3708 my $e_string = '';
4751              
4752             local $slash = 'm//';
4753              
4754             # P.1024 Appendix W.10 Multibyte Processing
4755             # of ISBN 1-56592-224-7 CJKV Information Processing
4756 2626         3672 # (and so on)
4757              
4758             my @char = $string =~ / \G (?>[^\x8E\xA1-\xFE\\]|\\$q_char|$q_char) /oxmsg;
4759 2626 100 66     27158  
4760 2626 50       11727 # without { ... }
4761 2588         5705 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4762             if ($string !~ /<
4763             return $string;
4764             }
4765             }
4766 2588         7301  
4767 38 50       262 E_STRING_LOOP:
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4768             while ($string !~ /\G \z/oxgc) {
4769             if (0) {
4770             }
4771 288         20962  
4772 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Eeuctw::PREMATCH()]}
4773 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4774             $e_string .= q{Eeuctw::PREMATCH()};
4775             $slash = 'div';
4776             }
4777              
4778 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Eeuctw::MATCH()]}
4779 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4780             $e_string .= q{Eeuctw::MATCH()};
4781             $slash = 'div';
4782             }
4783              
4784 0         0 # $', ${'} --> $', ${'}
4785 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4786             $e_string .= $1;
4787             $slash = 'div';
4788             }
4789              
4790 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Eeuctw::POSTMATCH()]}
4791 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4792             $e_string .= q{Eeuctw::POSTMATCH()};
4793             $slash = 'div';
4794             }
4795              
4796 0         0 # bareword
4797 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4798             $e_string .= $1;
4799             $slash = 'div';
4800             }
4801              
4802 0         0 # $0 --> $0
4803 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4804             $e_string .= $1;
4805             $slash = 'div';
4806 0         0 }
4807 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4808             $e_string .= $1;
4809             $slash = 'div';
4810             }
4811              
4812 0         0 # $$ --> $$
4813 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4814             $e_string .= $1;
4815             $slash = 'div';
4816             }
4817              
4818             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4819 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4820 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4821             $e_string .= e_capture($1);
4822             $slash = 'div';
4823 0         0 }
4824 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4825             $e_string .= e_capture($1);
4826             $slash = 'div';
4827             }
4828              
4829 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4830 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4831             $e_string .= e_capture($1.'->'.$2);
4832             $slash = 'div';
4833             }
4834              
4835 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4836 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4837             $e_string .= e_capture($1.'->'.$2);
4838             $slash = 'div';
4839             }
4840              
4841 0         0 # $$foo
4842 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4843             $e_string .= e_capture($1);
4844             $slash = 'div';
4845             }
4846              
4847 0         0 # ${ foo }
4848 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4849             $e_string .= '${' . $1 . '}';
4850             $slash = 'div';
4851             }
4852              
4853 0         0 # ${ ... }
4854 3         10 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4855             $e_string .= e_capture($1);
4856             $slash = 'div';
4857             }
4858              
4859             # variable or function
4860 3         91 # $ @ % & * $ #
4861 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) {
4862             $e_string .= $1;
4863             $slash = 'div';
4864             }
4865             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4866 0         0 # $ @ # \ ' " / ? ( ) [ ] < >
4867 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4868             $e_string .= $1;
4869             $slash = 'div';
4870             }
4871 0         0  
  0         0  
4872 0         0 # subroutines of package Eeuctw
  0         0  
4873 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4874 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4875 0         0 elsif ($string =~ /\G \b EUCTW::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4876 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4877 0         0 elsif ($string =~ /\G \b EUCTW::eval \b /oxgc) { $e_string .= 'eval EUCTW::escape'; $slash = 'm//'; }
  0         0  
4878 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4879 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Eeuctw::chop'; $slash = 'm//'; }
  0         0  
4880 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4881 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4882 0         0 elsif ($string =~ /\G \b EUCTW::index \b /oxgc) { $e_string .= 'EUCTW::index'; $slash = 'm//'; }
  0         0  
4883 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Eeuctw::index'; $slash = 'm//'; }
  0         0  
4884 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4885 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4886 0         0 elsif ($string =~ /\G \b EUCTW::rindex \b /oxgc) { $e_string .= 'EUCTW::rindex'; $slash = 'm//'; }
  0         0  
4887 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Eeuctw::rindex'; $slash = 'm//'; }
  0         0  
4888 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eeuctw::lc'; $slash = 'm//'; }
  0         0  
4889 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eeuctw::lcfirst'; $slash = 'm//'; }
  0         0  
4890 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eeuctw::uc'; $slash = 'm//'; }
  0         0  
4891             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eeuctw::ucfirst'; $slash = 'm//'; }
4892             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eeuctw::fc'; $slash = 'm//'; }
4893 0         0  
  0         0  
4894 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4895 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4896 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  
4897 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  
4898 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  
4899 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  
4900             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4901 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  
4902 0         0  
  0         0  
4903 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4904 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  
4905 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  
4906 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  
4907 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  
4908             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4909             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4910 0         0  
  0         0  
4911 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4912 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4913 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4914             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4915 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4916 0         0  
  0         0  
4917 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4918 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4919 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eeuctw::chr'; $slash = 'm//'; }
  0         0  
4920 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4921 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4922 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eeuctw::glob'; $slash = 'm//'; }
  0         0  
4923 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Eeuctw::lc_'; $slash = 'm//'; }
  0         0  
4924 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Eeuctw::lcfirst_'; $slash = 'm//'; }
  0         0  
4925 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Eeuctw::uc_'; $slash = 'm//'; }
  0         0  
4926 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Eeuctw::ucfirst_'; $slash = 'm//'; }
  0         0  
4927             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Eeuctw::fc_'; $slash = 'm//'; }
4928 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4929 0         0  
  0         0  
4930 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4931 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4932 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Eeuctw::chr_'; $slash = 'm//'; }
  0         0  
4933 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4934 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4935 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Eeuctw::glob_'; $slash = 'm//'; }
  0         0  
4936             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4937             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4938 0         0 # split
4939             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4940 0         0 $slash = 'm//';
4941 0         0  
4942 0         0 my $e = '';
4943             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4944             $e .= $1;
4945             }
4946 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          
4947             # end of split
4948             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Eeuctw::split' . $e; }
4949 0         0  
  0         0  
4950             # split scalar value
4951             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Eeuctw::split' . $e . e_string($1); next E_STRING_LOOP; }
4952 0         0  
  0         0  
4953 0         0 # split literal space
  0         0  
4954 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4955 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4956 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4957 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4958 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4959 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4960 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4961 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4962 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4963 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4964 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4965 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4966             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq {' '}; next E_STRING_LOOP; }
4967             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Eeuctw::split' . $e . qq {" "}; next E_STRING_LOOP; }
4968              
4969 0 0       0 # split qq//
  0         0  
  0         0  
4970             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4971 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4972 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4973 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4974 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4975 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  
4976 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  
4977 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  
4978 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  
4979             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4980 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 * *
4981             }
4982             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4983             }
4984             }
4985              
4986 0 0       0 # split qr//
  0         0  
  0         0  
4987             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4988 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4989 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4990 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4991 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4992 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  
4993 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  
4994 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  
4995 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  
4996 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  
4997             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4998 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 * *
4999             }
5000             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
5001             }
5002             }
5003              
5004 0 0       0 # split q//
  0         0  
  0         0  
5005             elsif ($string =~ /\G \b (q) \b /oxgc) {
5006 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
5007 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
5008 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
5009 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
5010 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  
5011 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  
5012 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  
5013 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  
5014             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
5015 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 * *
5016             }
5017             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
5018             }
5019             }
5020              
5021 0 0       0 # split m//
  0         0  
  0         0  
5022             elsif ($string =~ /\G \b (m) \b /oxgc) {
5023 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 # #
5024 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
5025 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
5026 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
5027 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  
5028 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  
5029 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  
5030 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  
5031 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  
5032             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
5033 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 * *
5034             }
5035             die __FILE__, ": Search pattern not terminated\n";
5036             }
5037             }
5038              
5039 0         0 # split ''
5040 0         0 elsif ($string =~ /\G (\') /oxgc) {
5041 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
5042 0         0 while ($string !~ /\G \z/oxgc) {
5043 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
5044 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
5045             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
5046 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
5047             }
5048             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
5049             }
5050              
5051 0         0 # split ""
5052 0         0 elsif ($string =~ /\G (\") /oxgc) {
5053 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
5054 0         0 while ($string !~ /\G \z/oxgc) {
5055 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
5056 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
5057             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
5058 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
5059             }
5060             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
5061             }
5062              
5063 0         0 # split //
5064 0         0 elsif ($string =~ /\G (\/) /oxgc) {
5065 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
5066 0         0 while ($string !~ /\G \z/oxgc) {
5067 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
5068 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
5069             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
5070 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
5071             }
5072             die __FILE__, ": Search pattern not terminated\n";
5073             }
5074             }
5075              
5076 0         0 # qq//
5077 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
5078 0         0 my $ope = $1;
5079             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
5080             $e_string .= e_qq($ope,$1,$3,$2);
5081 0         0 }
5082 0         0 else {
5083 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
5084 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
5085 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
5086 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
5087 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
5088 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
5089             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
5090 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
5091             }
5092             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
5093             }
5094             }
5095              
5096 0         0 # qx//
5097 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
5098 0         0 my $ope = $1;
5099             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
5100             $e_string .= e_qq($ope,$1,$3,$2);
5101 0         0 }
5102 0         0 else {
5103 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
5104 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
5105 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
5106 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
5107 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
5108 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
5109 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
5110             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
5111 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
5112             }
5113             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
5114             }
5115             }
5116              
5117 0         0 # q//
5118 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
5119 0         0 my $ope = $1;
5120             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
5121             $e_string .= e_q($ope,$1,$3,$2);
5122 0         0 }
5123 0         0 else {
5124 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
5125 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
5126 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
5127 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
5128 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
5129 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
5130             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
5131 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 * *
5132             }
5133             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
5134             }
5135             }
5136 0         0  
5137             # ''
5138             elsif ($string =~ /\G (?
5139 12         37  
5140             # ""
5141             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
5142 6         42  
5143             # ``
5144             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
5145 0         0  
5146             # <<>> (a safer ARGV)
5147             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
5148 0         0  
5149             # <<= <=> <= < operator
5150             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
5151 0         0  
5152             #
5153             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
5154              
5155 0         0 # --- glob
5156             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
5157             $e_string .= 'Eeuctw::glob("' . $1 . '")';
5158             }
5159              
5160 0         0 # << (bit shift) --- not here document
5161 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
5162             $slash = 'm//';
5163             $e_string .= $1;
5164             }
5165              
5166 0         0 # <<~'HEREDOC'
5167 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
5168 0         0 $slash = 'm//';
5169             my $here_quote = $1;
5170             my $delimiter = $2;
5171 0 0       0  
5172 0         0 # get here document
5173 0         0 if ($here_script eq '') {
5174             $here_script = CORE::substr $_, pos $_;
5175 0 0       0 $here_script =~ s/.*?\n//oxm;
5176 0         0 }
5177 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5178 0         0 my $heredoc = $1;
5179 0         0 my $indent = $2;
5180 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5181             push @heredoc, $heredoc . qq{\n$delimiter\n};
5182             push @heredoc_delimiter, qq{\\s*$delimiter};
5183 0         0 }
5184             else {
5185 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5186             }
5187             $e_string .= qq{<<'$delimiter'};
5188             }
5189              
5190 0         0 # <<~\HEREDOC
5191 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
5192 0         0 $slash = 'm//';
5193             my $here_quote = $1;
5194             my $delimiter = $2;
5195 0 0       0  
5196 0         0 # get here document
5197 0         0 if ($here_script eq '') {
5198             $here_script = CORE::substr $_, pos $_;
5199 0 0       0 $here_script =~ s/.*?\n//oxm;
5200 0         0 }
5201 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5202 0         0 my $heredoc = $1;
5203 0         0 my $indent = $2;
5204 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5205             push @heredoc, $heredoc . qq{\n$delimiter\n};
5206             push @heredoc_delimiter, qq{\\s*$delimiter};
5207 0         0 }
5208             else {
5209 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5210             }
5211             $e_string .= qq{<<\\$delimiter};
5212             }
5213              
5214 0         0 # <<~"HEREDOC"
5215 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
5216 0         0 $slash = 'm//';
5217             my $here_quote = $1;
5218             my $delimiter = $2;
5219 0 0       0  
5220 0         0 # get here document
5221 0         0 if ($here_script eq '') {
5222             $here_script = CORE::substr $_, pos $_;
5223 0 0       0 $here_script =~ s/.*?\n//oxm;
5224 0         0 }
5225 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5226 0         0 my $heredoc = $1;
5227 0         0 my $indent = $2;
5228 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5229             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
5230             push @heredoc_delimiter, qq{\\s*$delimiter};
5231 0         0 }
5232             else {
5233 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5234             }
5235             $e_string .= qq{<<"$delimiter"};
5236             }
5237              
5238 0         0 # <<~HEREDOC
5239 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
5240 0         0 $slash = 'm//';
5241             my $here_quote = $1;
5242             my $delimiter = $2;
5243 0 0       0  
5244 0         0 # get here document
5245 0         0 if ($here_script eq '') {
5246             $here_script = CORE::substr $_, pos $_;
5247 0 0       0 $here_script =~ s/.*?\n//oxm;
5248 0         0 }
5249 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5250 0         0 my $heredoc = $1;
5251 0         0 my $indent = $2;
5252 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5253             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
5254             push @heredoc_delimiter, qq{\\s*$delimiter};
5255 0         0 }
5256             else {
5257 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5258             }
5259             $e_string .= qq{<<$delimiter};
5260             }
5261              
5262 0         0 # <<~`HEREDOC`
5263 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
5264 0         0 $slash = 'm//';
5265             my $here_quote = $1;
5266             my $delimiter = $2;
5267 0 0       0  
5268 0         0 # get here document
5269 0         0 if ($here_script eq '') {
5270             $here_script = CORE::substr $_, pos $_;
5271 0 0       0 $here_script =~ s/.*?\n//oxm;
5272 0         0 }
5273 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
5274 0         0 my $heredoc = $1;
5275 0         0 my $indent = $2;
5276 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
5277             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
5278             push @heredoc_delimiter, qq{\\s*$delimiter};
5279 0         0 }
5280             else {
5281 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5282             }
5283             $e_string .= qq{<<`$delimiter`};
5284             }
5285              
5286 0         0 # <<'HEREDOC'
5287 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5288 0         0 $slash = 'm//';
5289             my $here_quote = $1;
5290             my $delimiter = $2;
5291 0 0       0  
5292 0         0 # get here document
5293 0         0 if ($here_script eq '') {
5294             $here_script = CORE::substr $_, pos $_;
5295 0 0       0 $here_script =~ s/.*?\n//oxm;
5296 0         0 }
5297 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5298             push @heredoc, $1 . qq{\n$delimiter\n};
5299             push @heredoc_delimiter, $delimiter;
5300 0         0 }
5301             else {
5302 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5303             }
5304             $e_string .= $here_quote;
5305             }
5306              
5307 0         0 # <<\HEREDOC
5308 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5309 0         0 $slash = 'm//';
5310             my $here_quote = $1;
5311             my $delimiter = $2;
5312 0 0       0  
5313 0         0 # get here document
5314 0         0 if ($here_script eq '') {
5315             $here_script = CORE::substr $_, pos $_;
5316 0 0       0 $here_script =~ s/.*?\n//oxm;
5317 0         0 }
5318 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5319             push @heredoc, $1 . qq{\n$delimiter\n};
5320             push @heredoc_delimiter, $delimiter;
5321 0         0 }
5322             else {
5323 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5324             }
5325             $e_string .= $here_quote;
5326             }
5327              
5328 0         0 # <<"HEREDOC"
5329 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5330 0         0 $slash = 'm//';
5331             my $here_quote = $1;
5332             my $delimiter = $2;
5333 0 0       0  
5334 0         0 # get here document
5335 0         0 if ($here_script eq '') {
5336             $here_script = CORE::substr $_, pos $_;
5337 0 0       0 $here_script =~ s/.*?\n//oxm;
5338 0         0 }
5339 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5340             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5341             push @heredoc_delimiter, $delimiter;
5342 0         0 }
5343             else {
5344 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5345             }
5346             $e_string .= $here_quote;
5347             }
5348              
5349 0         0 # <
5350 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5351 0         0 $slash = 'm//';
5352             my $here_quote = $1;
5353             my $delimiter = $2;
5354 0 0       0  
5355 0         0 # get here document
5356 0         0 if ($here_script eq '') {
5357             $here_script = CORE::substr $_, pos $_;
5358 0 0       0 $here_script =~ s/.*?\n//oxm;
5359 0         0 }
5360 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5361             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5362             push @heredoc_delimiter, $delimiter;
5363 0         0 }
5364             else {
5365 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5366             }
5367             $e_string .= $here_quote;
5368             }
5369              
5370 0         0 # <<`HEREDOC`
5371 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5372 0         0 $slash = 'm//';
5373             my $here_quote = $1;
5374             my $delimiter = $2;
5375 0 0       0  
5376 0         0 # get here document
5377 0         0 if ($here_script eq '') {
5378             $here_script = CORE::substr $_, pos $_;
5379 0 0       0 $here_script =~ s/.*?\n//oxm;
5380 0         0 }
5381 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5382             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5383             push @heredoc_delimiter, $delimiter;
5384 0         0 }
5385             else {
5386 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5387             }
5388             $e_string .= $here_quote;
5389             }
5390              
5391             # any operator before div
5392             elsif ($string =~ /\G (
5393             -- | \+\+ |
5394 0         0 [\)\}\]]
  39         73  
5395              
5396             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5397              
5398             # yada-yada or triple-dot operator
5399             elsif ($string =~ /\G (
5400 39         124 \.\.\.
  0         0  
5401              
5402             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5403              
5404             # any operator before m//
5405             elsif ($string =~ /\G ((?>
5406              
5407             !~~ | !~ | != | ! |
5408             %= | % |
5409             &&= | && | &= | &\.= | &\. | & |
5410             -= | -> | - |
5411             :(?>\s*)= |
5412             : |
5413             <<>> |
5414             <<= | <=> | <= | < |
5415             == | => | =~ | = |
5416             >>= | >> | >= | > |
5417             \*\*= | \*\* | \*= | \* |
5418             \+= | \+ |
5419             \.\. | \.= | \. |
5420             \/\/= | \/\/ |
5421             \/= | \/ |
5422             \? |
5423             \\ |
5424             \^= | \^\.= | \^\. | \^ |
5425             \b x= |
5426             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5427             ~~ | ~\. | ~ |
5428             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5429             \b(?: print )\b |
5430              
5431 0         0 [,;\(\{\[]
  49         94  
5432              
5433             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5434 49         149  
5435             # other any character
5436             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5437              
5438 179         617 # system error
5439             else {
5440             die __FILE__, ": Oops, this shouldn't happen!\n";
5441             }
5442 0         0 }
5443              
5444             return $e_string;
5445             }
5446              
5447             #
5448             # character class
5449 38     3065 0 278 #
5450             sub character_class {
5451 3065 100       5407 my($char,$modifier) = @_;
5452 3065 100       5172  
5453 115         264 if ($char eq '.') {
5454             if ($modifier =~ /s/) {
5455             return '${Eeuctw::dot_s}';
5456 23         59 }
5457             else {
5458             return '${Eeuctw::dot}';
5459             }
5460 92         196 }
5461             else {
5462             return Eeuctw::classic_character_class($char);
5463             }
5464             }
5465              
5466             #
5467             # escape capture ($1, $2, $3, ...)
5468             #
5469 2950     547 0 5688 sub e_capture {
5470 547         2274  
5471             return join '', '${Eeuctw::capture(', $_[0], ')}';
5472             return join '', '${', $_[0], '}';
5473             }
5474              
5475             #
5476             # escape transliteration (tr/// or y///)
5477 0     11 0 0 #
5478 11         55 sub e_tr {
5479 11   100     19 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5480             my $e_tr = '';
5481 11         42 $modifier ||= '';
5482              
5483             $slash = 'div';
5484 11         15  
5485             # quote character class 1
5486             $charclass = q_tr($charclass);
5487 11         26  
5488             # quote character class 2
5489             $charclass2 = q_tr($charclass2);
5490 11 50       18  
5491 11 0       32 # /b /B modifier
5492 0         0 if ($modifier =~ tr/bB//d) {
5493             if ($variable eq '') {
5494             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5495 0         0 }
5496             else {
5497             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5498             }
5499 0 100       0 }
5500 11         23 else {
5501             if ($variable eq '') {
5502             $e_tr = qq{Eeuctw::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5503 2         6 }
5504             else {
5505             $e_tr = qq{Eeuctw::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5506             }
5507             }
5508 9         33  
5509 11         22 # clear tr/// variable
5510             $tr_variable = '';
5511 11         14 $bind_operator = '';
5512              
5513             return $e_tr;
5514             }
5515              
5516             #
5517             # quote for escape transliteration (tr/// or y///)
5518 11     22 0 62 #
5519             sub q_tr {
5520             my($charclass) = @_;
5521 22 50       36  
    0          
    0          
    0          
    0          
    0          
5522 22         48 # quote character class
5523             if ($charclass !~ /'/oxms) {
5524             return e_q('', "'", "'", $charclass); # --> q' '
5525 22         38 }
5526             elsif ($charclass !~ /\//oxms) {
5527             return e_q('q', '/', '/', $charclass); # --> q/ /
5528 0         0 }
5529             elsif ($charclass !~ /\#/oxms) {
5530             return e_q('q', '#', '#', $charclass); # --> q# #
5531 0         0 }
5532             elsif ($charclass !~ /[\<\>]/oxms) {
5533             return e_q('q', '<', '>', $charclass); # --> q< >
5534 0         0 }
5535             elsif ($charclass !~ /[\(\)]/oxms) {
5536             return e_q('q', '(', ')', $charclass); # --> q( )
5537 0         0 }
5538             elsif ($charclass !~ /[\{\}]/oxms) {
5539             return e_q('q', '{', '}', $charclass); # --> q{ }
5540 0         0 }
5541 0 0       0 else {
5542 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5543             if ($charclass !~ /\Q$char\E/xms) {
5544             return e_q('q', $char, $char, $charclass);
5545             }
5546             }
5547 0         0 }
5548              
5549             return e_q('q', '{', '}', $charclass);
5550             }
5551              
5552             #
5553             # escape q string (q//, '')
5554 0     2434 0 0 #
5555             sub e_q {
5556 2434         6417 my($ope,$delimiter,$end_delimiter,$string) = @_;
5557              
5558 2434         3447 $slash = 'div';
5559              
5560             return join '', $ope, $delimiter, $string, $end_delimiter;
5561             }
5562              
5563             #
5564             # escape qq string (qq//, "", qx//, ``)
5565 2434     7014 0 12946 #
5566             sub e_qq {
5567 7014         17938 my($ope,$delimiter,$end_delimiter,$string) = @_;
5568              
5569 7014         9523 $slash = 'div';
5570 7014         8566  
5571             my $left_e = 0;
5572             my $right_e = 0;
5573 7014         8139  
5574             # split regexp
5575             my @char = $string =~ /\G((?>
5576             [^\x8E\xA1-\xFE\\\$]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
5577             \\x\{ (?>[0-9A-Fa-f]+) \} |
5578             \\o\{ (?>[0-7]+) \} |
5579             \\N\{ (?>[^\x8E\xA1-\xFE0-9\}][^\x8E\xA1-\xFE\}]*) \} |
5580             \\ $q_char |
5581             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5582             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5583             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5584             \$ (?>\s* [0-9]+) |
5585             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5586             \$ \$ (?![\w\{]) |
5587             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5588             $q_char
5589 7014         304113 ))/oxmsg;
5590              
5591             for (my $i=0; $i <= $#char; $i++) {
5592 7014 50 66     24607  
    50 33        
    100          
    100          
    50          
5593 217311         715135 # "\L\u" --> "\u\L"
5594             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5595             @char[$i,$i+1] = @char[$i+1,$i];
5596             }
5597              
5598 0         0 # "\U\l" --> "\l\U"
5599             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5600             @char[$i,$i+1] = @char[$i+1,$i];
5601             }
5602              
5603 0         0 # octal escape sequence
5604             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5605             $char[$i] = Eeuctw::octchr($1);
5606             }
5607              
5608 1         4 # hexadecimal escape sequence
5609             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5610             $char[$i] = Eeuctw::hexchr($1);
5611             }
5612              
5613 1         4 # \N{CHARNAME} --> N{CHARNAME}
5614             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x8E\xA1-\xFE0-9\}][^\x8E\xA1-\xFE\}]*) \} ) \z/oxms) {
5615             $char[$i] = $1;
5616 0 100       0 }
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5617              
5618             if (0) {
5619             }
5620              
5621             # \F
5622             #
5623             # P.69 Table 2-6. Translation escapes
5624             # in Chapter 2: Bits and Pieces
5625             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5626             # (and so on)
5627 217311         1791276  
5628 0 50       0 # \u \l \U \L \F \Q \E
5629 602         1314 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5630             if ($right_e < $left_e) {
5631             $char[$i] = '\\' . $char[$i];
5632             }
5633             }
5634             elsif ($char[$i] eq '\u') {
5635              
5636             # "STRING @{[ LIST EXPR ]} MORE STRING"
5637              
5638             # P.257 Other Tricks You Can Do with Hard References
5639             # in Chapter 8: References
5640             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5641              
5642             # P.353 Other Tricks You Can Do with Hard References
5643             # in Chapter 8: References
5644             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5645              
5646 0         0 # (and so on)
5647 0         0  
5648             $char[$i] = '@{[Eeuctw::ucfirst qq<';
5649             $left_e++;
5650 0         0 }
5651 0         0 elsif ($char[$i] eq '\l') {
5652             $char[$i] = '@{[Eeuctw::lcfirst qq<';
5653             $left_e++;
5654 0         0 }
5655 0         0 elsif ($char[$i] eq '\U') {
5656             $char[$i] = '@{[Eeuctw::uc qq<';
5657             $left_e++;
5658 0         0 }
5659 6         7 elsif ($char[$i] eq '\L') {
5660             $char[$i] = '@{[Eeuctw::lc qq<';
5661             $left_e++;
5662 6         13 }
5663 9         11 elsif ($char[$i] eq '\F') {
5664             $char[$i] = '@{[Eeuctw::fc qq<';
5665             $left_e++;
5666 9         17 }
5667 0         0 elsif ($char[$i] eq '\Q') {
5668             $char[$i] = '@{[CORE::quotemeta qq<';
5669             $left_e++;
5670 0 50       0 }
5671 12         24 elsif ($char[$i] eq '\E') {
5672 12         15 if ($right_e < $left_e) {
5673             $char[$i] = '>]}';
5674             $right_e++;
5675 12         35 }
5676             else {
5677             $char[$i] = '';
5678             }
5679 0         0 }
5680 0 0       0 elsif ($char[$i] eq '\Q') {
5681 0         0 while (1) {
5682             if (++$i > $#char) {
5683 0 0       0 last;
5684 0         0 }
5685             if ($char[$i] eq '\E') {
5686             last;
5687             }
5688             }
5689             }
5690             elsif ($char[$i] eq '\E') {
5691             }
5692              
5693             # $0 --> $0
5694             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5695             }
5696             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5697             }
5698              
5699             # $$ --> $$
5700             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5701             }
5702              
5703             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5704 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5705             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5706             $char[$i] = e_capture($1);
5707 415         852 }
5708             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5709             $char[$i] = e_capture($1);
5710             }
5711              
5712 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5713             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5714             $char[$i] = e_capture($1.'->'.$2);
5715             }
5716              
5717 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5718             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5719             $char[$i] = e_capture($1.'->'.$2);
5720             }
5721              
5722 0         0 # $$foo
5723             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5724             $char[$i] = e_capture($1);
5725             }
5726              
5727 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eeuctw::PREMATCH()
5728             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5729             $char[$i] = '@{[Eeuctw::PREMATCH()]}';
5730             }
5731              
5732 44         119 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eeuctw::MATCH()
5733             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5734             $char[$i] = '@{[Eeuctw::MATCH()]}';
5735             }
5736              
5737 45         132 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eeuctw::POSTMATCH()
5738             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5739             $char[$i] = '@{[Eeuctw::POSTMATCH()]}';
5740             }
5741              
5742             # ${ foo } --> ${ foo }
5743             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5744             }
5745              
5746 33         92 # ${ ... }
5747             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5748             $char[$i] = e_capture($1);
5749             }
5750             }
5751 0 100       0  
5752 7014         13240 # return string
5753             if ($left_e > $right_e) {
5754 3         288 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5755             }
5756             return join '', $ope, $delimiter, @char, $end_delimiter;
5757             }
5758              
5759             #
5760             # escape qw string (qw//)
5761 7011     34 0 65123 #
5762             sub e_qw {
5763 34         241 my($ope,$delimiter,$end_delimiter,$string) = @_;
5764              
5765             $slash = 'div';
5766 34         80  
  34         322  
5767 621 50       978 # choice again delimiter
    0          
    0          
    0          
    0          
5768 34         165 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5769             if (not $octet{$end_delimiter}) {
5770             return join '', $ope, $delimiter, $string, $end_delimiter;
5771 34         227 }
5772             elsif (not $octet{')'}) {
5773             return join '', $ope, '(', $string, ')';
5774 0         0 }
5775             elsif (not $octet{'}'}) {
5776             return join '', $ope, '{', $string, '}';
5777 0         0 }
5778             elsif (not $octet{']'}) {
5779             return join '', $ope, '[', $string, ']';
5780 0         0 }
5781             elsif (not $octet{'>'}) {
5782             return join '', $ope, '<', $string, '>';
5783 0         0 }
5784 0 0       0 else {
5785 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5786             if (not $octet{$char}) {
5787             return join '', $ope, $char, $string, $char;
5788             }
5789             }
5790             }
5791 0         0  
5792 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5793 0         0 my @string = CORE::split(/\s+/, $string);
5794 0         0 for my $string (@string) {
5795 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5796 0         0 for my $octet (@octet) {
5797             if ($octet =~ /\A (['\\]) \z/oxms) {
5798             $octet = '\\' . $1;
5799 0         0 }
5800             }
5801 0         0 $string = join '', @octet;
  0         0  
5802             }
5803             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5804             }
5805              
5806             #
5807             # escape here document (<<"HEREDOC", <
5808 0     108 0 0 #
5809             sub e_heredoc {
5810 108         291 my($string) = @_;
5811              
5812 108         166 $slash = 'm//';
5813              
5814 108         432 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5815 108         164  
5816             my $left_e = 0;
5817             my $right_e = 0;
5818 108         139  
5819             # split regexp
5820             my @char = $string =~ /\G((?>
5821             [^\x8E\xA1-\xFE\\\$]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
5822             \\x\{ (?>[0-9A-Fa-f]+) \} |
5823             \\o\{ (?>[0-7]+) \} |
5824             \\N\{ (?>[^\x8E\xA1-\xFE0-9\}][^\x8E\xA1-\xFE\}]*) \} |
5825             \\ $q_char |
5826             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5827             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5828             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5829             \$ (?>\s* [0-9]+) |
5830             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5831             \$ \$ (?![\w\{]) |
5832             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5833             $q_char
5834 108         13393 ))/oxmsg;
5835              
5836             for (my $i=0; $i <= $#char; $i++) {
5837 108 50 66     540  
    50 33        
    100          
    100          
    50          
5838 3265         9705 # "\L\u" --> "\u\L"
5839             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5840             @char[$i,$i+1] = @char[$i+1,$i];
5841             }
5842              
5843 0         0 # "\U\l" --> "\l\U"
5844             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5845             @char[$i,$i+1] = @char[$i+1,$i];
5846             }
5847              
5848 0         0 # octal escape sequence
5849             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5850             $char[$i] = Eeuctw::octchr($1);
5851             }
5852              
5853 1         3 # hexadecimal escape sequence
5854             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5855             $char[$i] = Eeuctw::hexchr($1);
5856             }
5857              
5858 1         3 # \N{CHARNAME} --> N{CHARNAME}
5859             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x8E\xA1-\xFE0-9\}][^\x8E\xA1-\xFE\}]*) \} ) \z/oxms) {
5860             $char[$i] = $1;
5861 0 100       0 }
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5862              
5863             if (0) {
5864             }
5865 3265         28372  
5866 0 50       0 # \u \l \U \L \F \Q \E
5867 72         145 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5868             if ($right_e < $left_e) {
5869             $char[$i] = '\\' . $char[$i];
5870             }
5871 0         0 }
5872 0         0 elsif ($char[$i] eq '\u') {
5873             $char[$i] = '@{[Eeuctw::ucfirst qq<';
5874             $left_e++;
5875 0         0 }
5876 0         0 elsif ($char[$i] eq '\l') {
5877             $char[$i] = '@{[Eeuctw::lcfirst qq<';
5878             $left_e++;
5879 0         0 }
5880 0         0 elsif ($char[$i] eq '\U') {
5881             $char[$i] = '@{[Eeuctw::uc qq<';
5882             $left_e++;
5883 0         0 }
5884 6         11 elsif ($char[$i] eq '\L') {
5885             $char[$i] = '@{[Eeuctw::lc qq<';
5886             $left_e++;
5887 6         9 }
5888 0         0 elsif ($char[$i] eq '\F') {
5889             $char[$i] = '@{[Eeuctw::fc qq<';
5890             $left_e++;
5891 0         0 }
5892 0         0 elsif ($char[$i] eq '\Q') {
5893             $char[$i] = '@{[CORE::quotemeta qq<';
5894             $left_e++;
5895 0 50       0 }
5896 3         7 elsif ($char[$i] eq '\E') {
5897 3         5 if ($right_e < $left_e) {
5898             $char[$i] = '>]}';
5899             $right_e++;
5900 3         4 }
5901             else {
5902             $char[$i] = '';
5903             }
5904 0         0 }
5905 0 0       0 elsif ($char[$i] eq '\Q') {
5906 0         0 while (1) {
5907             if (++$i > $#char) {
5908 0 0       0 last;
5909 0         0 }
5910             if ($char[$i] eq '\E') {
5911             last;
5912             }
5913             }
5914             }
5915             elsif ($char[$i] eq '\E') {
5916             }
5917              
5918             # $0 --> $0
5919             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5920             }
5921             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5922             }
5923              
5924             # $$ --> $$
5925             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5926             }
5927              
5928             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5929 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5930             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5931             $char[$i] = e_capture($1);
5932 0         0 }
5933             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5934             $char[$i] = e_capture($1);
5935             }
5936              
5937 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5938             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5939             $char[$i] = e_capture($1.'->'.$2);
5940             }
5941              
5942 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5943             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5944             $char[$i] = e_capture($1.'->'.$2);
5945             }
5946              
5947 0         0 # $$foo
5948             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5949             $char[$i] = e_capture($1);
5950             }
5951              
5952 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eeuctw::PREMATCH()
5953             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5954             $char[$i] = '@{[Eeuctw::PREMATCH()]}';
5955             }
5956              
5957 8         162 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eeuctw::MATCH()
5958             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5959             $char[$i] = '@{[Eeuctw::MATCH()]}';
5960             }
5961              
5962 8         49 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eeuctw::POSTMATCH()
5963             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5964             $char[$i] = '@{[Eeuctw::POSTMATCH()]}';
5965             }
5966              
5967             # ${ foo } --> ${ foo }
5968             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5969             }
5970              
5971 6         36 # ${ ... }
5972             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5973             $char[$i] = e_capture($1);
5974             }
5975             }
5976 0 100       0  
5977 108         248 # return string
5978             if ($left_e > $right_e) {
5979 3         169 return join '', @char, '>]}' x ($left_e - $right_e);
5980             }
5981             return join '', @char;
5982             }
5983              
5984             #
5985             # escape regexp (m//, qr//)
5986 105     1426 0 803 #
5987 1426   100     6433 sub e_qr {
5988             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5989 1426         5068 $modifier ||= '';
5990 1426 50       2937  
5991 1426         3591 $modifier =~ tr/p//d;
5992 0         0 if ($modifier =~ /([adlu])/oxms) {
5993 0 0       0 my $line = 0;
5994 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5995 0         0 if ($filename ne __FILE__) {
5996             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5997             last;
5998 0         0 }
5999             }
6000             die qq{Unsupported modifier "$1" used at line $line.\n};
6001 0         0 }
6002              
6003             $slash = 'div';
6004 1426 100       2659  
    100          
6005 1426         4412 # literal null string pattern
6006 8         10 if ($string eq '') {
6007 8         10 $modifier =~ tr/bB//d;
6008             $modifier =~ tr/i//d;
6009             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6010             }
6011              
6012             # /b /B modifier
6013             elsif ($modifier =~ tr/bB//d) {
6014 8 50       42  
6015 60         231 # choice again delimiter
6016 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6017 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6018 0         0 my %octet = map {$_ => 1} @char;
6019 0         0 if (not $octet{')'}) {
6020             $delimiter = '(';
6021             $end_delimiter = ')';
6022 0         0 }
6023 0         0 elsif (not $octet{'}'}) {
6024             $delimiter = '{';
6025             $end_delimiter = '}';
6026 0         0 }
6027 0         0 elsif (not $octet{']'}) {
6028             $delimiter = '[';
6029             $end_delimiter = ']';
6030 0         0 }
6031 0         0 elsif (not $octet{'>'}) {
6032             $delimiter = '<';
6033             $end_delimiter = '>';
6034 0         0 }
6035 0 0       0 else {
6036 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6037 0         0 if (not $octet{$char}) {
6038 0         0 $delimiter = $char;
6039             $end_delimiter = $char;
6040             last;
6041             }
6042             }
6043             }
6044 0 100 100     0 }
6045 60         415  
6046             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6047             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
6048 18         111 }
6049             else {
6050             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6051             }
6052 42 100       256 }
6053 1358         3767  
6054             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6055             my $metachar = qr/[\@\\|[\]{^]/oxms;
6056 1358         4990  
6057             # split regexp
6058             my @char = $string =~ /\G((?>
6059             [^\x8E\xA1-\xFE\\\$\@\[\(]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
6060             \\x (?>[0-9A-Fa-f]{1,2}) |
6061             \\ (?>[0-7]{2,3}) |
6062             \\c [\x40-\x5F] |
6063             \\x\{ (?>[0-9A-Fa-f]+) \} |
6064             \\o\{ (?>[0-7]+) \} |
6065             \\[bBNpP]\{ (?>[^\x8E\xA1-\xFE0-9\}][^\x8E\xA1-\xFE\}]*) \} |
6066             \\ $q_char |
6067             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6068             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6069             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6070             [\$\@] $qq_variable |
6071             \$ (?>\s* [0-9]+) |
6072             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6073             \$ \$ (?![\w\{]) |
6074             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6075             \[\^ |
6076             \[\: (?>[a-z]+) :\] |
6077             \[\:\^ (?>[a-z]+) :\] |
6078             \(\? |
6079             $q_char
6080             ))/oxmsg;
6081 1358 50       148540  
6082 1358         6478 # choice again delimiter
  0         0  
6083 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6084 0         0 my %octet = map {$_ => 1} @char;
6085 0         0 if (not $octet{')'}) {
6086             $delimiter = '(';
6087             $end_delimiter = ')';
6088 0         0 }
6089 0         0 elsif (not $octet{'}'}) {
6090             $delimiter = '{';
6091             $end_delimiter = '}';
6092 0         0 }
6093 0         0 elsif (not $octet{']'}) {
6094             $delimiter = '[';
6095             $end_delimiter = ']';
6096 0         0 }
6097 0         0 elsif (not $octet{'>'}) {
6098             $delimiter = '<';
6099             $end_delimiter = '>';
6100 0         0 }
6101 0 0       0 else {
6102 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6103 0         0 if (not $octet{$char}) {
6104 0         0 $delimiter = $char;
6105             $end_delimiter = $char;
6106             last;
6107             }
6108             }
6109             }
6110 0         0 }
6111 1358         2226  
6112 1358         1895 my $left_e = 0;
6113             my $right_e = 0;
6114             for (my $i=0; $i <= $#char; $i++) {
6115 1358 50 66     3897  
    50 66        
    100          
    100          
    100          
    100          
6116 3269         19722 # "\L\u" --> "\u\L"
6117             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6118             @char[$i,$i+1] = @char[$i+1,$i];
6119             }
6120              
6121 0         0 # "\U\l" --> "\l\U"
6122             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6123             @char[$i,$i+1] = @char[$i+1,$i];
6124             }
6125              
6126 0         0 # octal escape sequence
6127             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6128             $char[$i] = Eeuctw::octchr($1);
6129             }
6130              
6131 1         3 # hexadecimal escape sequence
6132             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6133             $char[$i] = Eeuctw::hexchr($1);
6134             }
6135              
6136             # \b{...} --> b\{...}
6137             # \B{...} --> B\{...}
6138             # \N{CHARNAME} --> N\{CHARNAME}
6139             # \p{PROPERTY} --> p\{PROPERTY}
6140 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6141             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x8E\xA1-\xFE0-9\}][^\x8E\xA1-\xFE\}]*) \} ) \z/oxms) {
6142             $char[$i] = $1 . '\\' . $2;
6143             }
6144              
6145 6         30 # \p, \P, \X --> p, P, X
6146             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6147             $char[$i] = $1;
6148 4 100 100     13 }
    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          
6149              
6150             if (0) {
6151             }
6152 3269         10163  
6153 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
6154 6         82 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6155             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)) {
6156             $char[$i] .= join '', splice @char, $i+1, 3;
6157 0         0 }
6158             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)) {
6159             $char[$i] .= join '', splice @char, $i+1, 2;
6160 0         0 }
6161             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)) {
6162             $char[$i] .= join '', splice @char, $i+1, 1;
6163             }
6164             }
6165              
6166 0         0 # open character class [...]
6167             elsif ($char[$i] eq '[') {
6168             my $left = $i;
6169              
6170             # [] make die "Unmatched [] in regexp ...\n"
6171 586 100       992 # (and so on)
6172 586         1484  
6173             if ($char[$i+1] eq ']') {
6174             $i++;
6175 3         4 }
6176 586 50       781  
6177 2583         4006 while (1) {
6178             if (++$i > $#char) {
6179 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6180 2583         4348 }
6181             if ($char[$i] eq ']') {
6182             my $right = $i;
6183 586 100       840  
6184 586         3774 # [...]
  90         242  
6185             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6186             splice @char, $left, $right-$left+1, sprintf(q{@{[Eeuctw::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6187 270         417 }
6188             else {
6189             splice @char, $left, $right-$left+1, Eeuctw::charlist_qr(@char[$left+1..$right-1], $modifier);
6190 496         2981 }
6191 586         1122  
6192             $i = $left;
6193             last;
6194             }
6195             }
6196             }
6197              
6198 586         1719 # open character class [^...]
6199             elsif ($char[$i] eq '[^') {
6200             my $left = $i;
6201              
6202             # [^] make die "Unmatched [] in regexp ...\n"
6203 328 100       462 # (and so on)
6204 328         717  
6205             if ($char[$i+1] eq ']') {
6206             $i++;
6207 5         10 }
6208 328 50       412  
6209 1447         2110 while (1) {
6210             if (++$i > $#char) {
6211 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6212 1447         2175 }
6213             if ($char[$i] eq ']') {
6214             my $right = $i;
6215 328 100       459  
6216 328         1756 # [^...]
  90         197  
6217             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6218             splice @char, $left, $right-$left+1, sprintf(q{@{[Eeuctw::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6219 270         458 }
6220             else {
6221             splice @char, $left, $right-$left+1, Eeuctw::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6222 238         886 }
6223 328         724  
6224             $i = $left;
6225             last;
6226             }
6227             }
6228             }
6229              
6230 328         978 # rewrite character class or escape character
6231             elsif (my $char = character_class($char[$i],$modifier)) {
6232             $char[$i] = $char;
6233             }
6234              
6235 215 50       523 # /i modifier
6236 54         138 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eeuctw::uc($char[$i]) ne Eeuctw::fc($char[$i]))) {
6237             if (CORE::length(Eeuctw::fc($char[$i])) == 1) {
6238             $char[$i] = '[' . Eeuctw::uc($char[$i]) . Eeuctw::fc($char[$i]) . ']';
6239 54         128 }
6240             else {
6241             $char[$i] = '(?:' . Eeuctw::uc($char[$i]) . '|' . Eeuctw::fc($char[$i]) . ')';
6242             }
6243             }
6244              
6245 0 50       0 # \u \l \U \L \F \Q \E
6246 1         4 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6247             if ($right_e < $left_e) {
6248             $char[$i] = '\\' . $char[$i];
6249             }
6250 0         0 }
6251 0         0 elsif ($char[$i] eq '\u') {
6252             $char[$i] = '@{[Eeuctw::ucfirst qq<';
6253             $left_e++;
6254 0         0 }
6255 0         0 elsif ($char[$i] eq '\l') {
6256             $char[$i] = '@{[Eeuctw::lcfirst qq<';
6257             $left_e++;
6258 0         0 }
6259 1         3 elsif ($char[$i] eq '\U') {
6260             $char[$i] = '@{[Eeuctw::uc qq<';
6261             $left_e++;
6262 1         3 }
6263 1         2 elsif ($char[$i] eq '\L') {
6264             $char[$i] = '@{[Eeuctw::lc qq<';
6265             $left_e++;
6266 1         3 }
6267 9         16 elsif ($char[$i] eq '\F') {
6268             $char[$i] = '@{[Eeuctw::fc qq<';
6269             $left_e++;
6270 9         23 }
6271 20         38 elsif ($char[$i] eq '\Q') {
6272             $char[$i] = '@{[CORE::quotemeta qq<';
6273             $left_e++;
6274 20 50       48 }
6275 31         74 elsif ($char[$i] eq '\E') {
6276 31         42 if ($right_e < $left_e) {
6277             $char[$i] = '>]}';
6278             $right_e++;
6279 31         69 }
6280             else {
6281             $char[$i] = '';
6282             }
6283 0         0 }
6284 0 0       0 elsif ($char[$i] eq '\Q') {
6285 0         0 while (1) {
6286             if (++$i > $#char) {
6287 0 0       0 last;
6288 0         0 }
6289             if ($char[$i] eq '\E') {
6290             last;
6291             }
6292             }
6293             }
6294             elsif ($char[$i] eq '\E') {
6295             }
6296              
6297 0 0       0 # $0 --> $0
6298 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6299             if ($ignorecase) {
6300             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6301             }
6302 0 0       0 }
6303 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6304             if ($ignorecase) {
6305             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6306             }
6307             }
6308              
6309             # $$ --> $$
6310             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6311             }
6312              
6313             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6314 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6315 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6316 0         0 $char[$i] = e_capture($1);
6317             if ($ignorecase) {
6318             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6319             }
6320 0         0 }
6321 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6322 0         0 $char[$i] = e_capture($1);
6323             if ($ignorecase) {
6324             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6325             }
6326             }
6327              
6328 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6329 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) {
6330 0         0 $char[$i] = e_capture($1.'->'.$2);
6331             if ($ignorecase) {
6332             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6333             }
6334             }
6335              
6336 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6337 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) {
6338 0         0 $char[$i] = e_capture($1.'->'.$2);
6339             if ($ignorecase) {
6340             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6341             }
6342             }
6343              
6344 0         0 # $$foo
6345 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6346 0         0 $char[$i] = e_capture($1);
6347             if ($ignorecase) {
6348             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6349             }
6350             }
6351              
6352 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eeuctw::PREMATCH()
6353 8         25 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6354             if ($ignorecase) {
6355             $char[$i] = '@{[Eeuctw::ignorecase(Eeuctw::PREMATCH())]}';
6356 0         0 }
6357             else {
6358             $char[$i] = '@{[Eeuctw::PREMATCH()]}';
6359             }
6360             }
6361              
6362 8 50       22 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eeuctw::MATCH()
6363 8         26 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6364             if ($ignorecase) {
6365             $char[$i] = '@{[Eeuctw::ignorecase(Eeuctw::MATCH())]}';
6366 0         0 }
6367             else {
6368             $char[$i] = '@{[Eeuctw::MATCH()]}';
6369             }
6370             }
6371              
6372 8 50       27 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eeuctw::POSTMATCH()
6373 6         18 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6374             if ($ignorecase) {
6375             $char[$i] = '@{[Eeuctw::ignorecase(Eeuctw::POSTMATCH())]}';
6376 0         0 }
6377             else {
6378             $char[$i] = '@{[Eeuctw::POSTMATCH()]}';
6379             }
6380             }
6381              
6382 6 0       18 # ${ foo }
6383 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) {
6384             if ($ignorecase) {
6385             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6386             }
6387             }
6388              
6389 0         0 # ${ ... }
6390 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6391 0         0 $char[$i] = e_capture($1);
6392             if ($ignorecase) {
6393             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6394             }
6395             }
6396              
6397 0         0 # $scalar or @array
6398 29 100       79 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6399 29         100 $char[$i] = e_string($char[$i]);
6400             if ($ignorecase) {
6401             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6402             }
6403             }
6404              
6405 4 100 66     14 # quote character before ? + * {
    50          
6406             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6407             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6408 188         1484 }
6409 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6410 0         0 my $char = $char[$i-1];
6411             if ($char[$i] eq '{') {
6412             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6413 0         0 }
6414             else {
6415             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6416             }
6417 0         0 }
6418             else {
6419             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6420             }
6421             }
6422             }
6423 187         1066  
6424 1358 50       4130 # make regexp string
6425 1358 0 0     3002 $modifier =~ tr/i//d;
6426 0         0 if ($left_e > $right_e) {
6427             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6428             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6429 0         0 }
6430             else {
6431             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6432 0 100 100     0 }
6433 1358         7450 }
6434             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6435             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6436 42         473 }
6437             else {
6438             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6439             }
6440             }
6441              
6442             #
6443             # double quote stuff
6444 1316     540 0 12555 #
6445             sub qq_stuff {
6446             my($delimiter,$end_delimiter,$stuff) = @_;
6447 540 100       977  
6448 540         1119 # scalar variable or array variable
6449             if ($stuff =~ /\A [\$\@] /oxms) {
6450             return $stuff;
6451             }
6452 300         1038  
  240         570  
6453 280         813 # quote by delimiter
6454 240 50       589 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6455 240 50       479 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6456 240 50       372 next if $char eq $delimiter;
6457 240         416 next if $char eq $end_delimiter;
6458             if (not $octet{$char}) {
6459             return join '', 'qq', $char, $stuff, $char;
6460 240         1037 }
6461             }
6462             return join '', 'qq', '<', $stuff, '>';
6463             }
6464              
6465             #
6466             # escape regexp (m'', qr'', and m''b, qr''b)
6467 0     39 0 0 #
6468 39   100     221 sub e_qr_q {
6469             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6470 39         141 $modifier ||= '';
6471 39 50       79  
6472 39         109 $modifier =~ tr/p//d;
6473 0         0 if ($modifier =~ /([adlu])/oxms) {
6474 0 0       0 my $line = 0;
6475 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6476 0         0 if ($filename ne __FILE__) {
6477             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6478             last;
6479 0         0 }
6480             }
6481             die qq{Unsupported modifier "$1" used at line $line.\n};
6482 0         0 }
6483              
6484             $slash = 'div';
6485 39 100       63  
    100          
6486 39         133 # literal null string pattern
6487 8         11 if ($string eq '') {
6488 8         9 $modifier =~ tr/bB//d;
6489             $modifier =~ tr/i//d;
6490             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6491             }
6492              
6493 8         38 # with /b /B modifier
6494             elsif ($modifier =~ tr/bB//d) {
6495             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6496             }
6497              
6498 17         54 # without /b /B modifier
6499             else {
6500             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6501             }
6502             }
6503              
6504             #
6505             # escape regexp (m'', qr'')
6506 14     14 0 50 #
6507             sub e_qr_qt {
6508 14 100       47 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6509              
6510             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6511 14         47  
6512             # split regexp
6513             my @char = $string =~ /\G((?>
6514             [^\x8E\xA1-\xFE\\\[\$\@\/] |
6515             [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
6516             \[\^ |
6517             \[\: (?>[a-z]+) \:\] |
6518             \[\:\^ (?>[a-z]+) \:\] |
6519             [\$\@\/] |
6520             \\ (?:$q_char) |
6521             (?:$q_char)
6522             ))/oxmsg;
6523 14         775  
6524 14 50 100     78 # unescape character
    50 100        
    50 66        
    50          
    100          
    50          
6525             for (my $i=0; $i <= $#char; $i++) {
6526             if (0) {
6527             }
6528 27         161  
6529 0         0 # open character class [...]
6530 0 0       0 elsif ($char[$i] eq '[') {
6531 0         0 my $left = $i;
6532             if ($char[$i+1] eq ']') {
6533 0         0 $i++;
6534 0 0       0 }
6535 0         0 while (1) {
6536             if (++$i > $#char) {
6537 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6538 0         0 }
6539             if ($char[$i] eq ']') {
6540             my $right = $i;
6541 0         0  
6542             # [...]
6543 0         0 splice @char, $left, $right-$left+1, Eeuctw::charlist_qr(@char[$left+1..$right-1], $modifier);
6544 0         0  
6545             $i = $left;
6546             last;
6547             }
6548             }
6549             }
6550              
6551 0         0 # open character class [^...]
6552 0 0       0 elsif ($char[$i] eq '[^') {
6553 0         0 my $left = $i;
6554             if ($char[$i+1] eq ']') {
6555 0         0 $i++;
6556 0 0       0 }
6557 0         0 while (1) {
6558             if (++$i > $#char) {
6559 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6560 0         0 }
6561             if ($char[$i] eq ']') {
6562             my $right = $i;
6563 0         0  
6564             # [^...]
6565 0         0 splice @char, $left, $right-$left+1, Eeuctw::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6566 0         0  
6567             $i = $left;
6568             last;
6569             }
6570             }
6571             }
6572              
6573 0         0 # escape $ @ / and \
6574             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6575             $char[$i] = '\\' . $char[$i];
6576             }
6577              
6578 0         0 # rewrite character class or escape character
6579             elsif (my $char = character_class($char[$i],$modifier)) {
6580             $char[$i] = $char;
6581             }
6582              
6583 0 50       0 # /i modifier
6584 4         11 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eeuctw::uc($char[$i]) ne Eeuctw::fc($char[$i]))) {
6585             if (CORE::length(Eeuctw::fc($char[$i])) == 1) {
6586             $char[$i] = '[' . Eeuctw::uc($char[$i]) . Eeuctw::fc($char[$i]) . ']';
6587 4         11 }
6588             else {
6589             $char[$i] = '(?:' . Eeuctw::uc($char[$i]) . '|' . Eeuctw::fc($char[$i]) . ')';
6590             }
6591             }
6592              
6593 0 0       0 # quote character before ? + * {
6594             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6595             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6596 0         0 }
6597             else {
6598             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6599             }
6600             }
6601 0         0 }
6602 14         33  
6603             $delimiter = '/';
6604 14         18 $end_delimiter = '/';
6605 14         98  
6606             $modifier =~ tr/i//d;
6607             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6608             }
6609              
6610             #
6611             # escape regexp (m''b, qr''b)
6612 14     17 0 155 #
6613             sub e_qr_qb {
6614             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6615 17         51  
6616             # split regexp
6617             my @char = $string =~ /\G ((?>[^\\]|\\\\|[\x00-\xFF])) /oxmsg;
6618 17         80  
6619 17 50       76 # unescape character
    50          
6620             for (my $i=0; $i <= $#char; $i++) {
6621             if (0) {
6622             }
6623 51         194  
6624             # remain \\
6625             elsif ($char[$i] eq '\\\\') {
6626             }
6627              
6628 0         0 # escape $ @ / and \
6629             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6630             $char[$i] = '\\' . $char[$i];
6631             }
6632 0         0 }
6633 17         29  
6634 17         25 $delimiter = '/';
6635             $end_delimiter = '/';
6636             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6637             }
6638              
6639             #
6640             # escape regexp (s/here//)
6641 17     122 0 112 #
6642 122   100     510 sub e_s1 {
6643             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6644 122         531 $modifier ||= '';
6645 122 50       217  
6646 122         394 $modifier =~ tr/p//d;
6647 0         0 if ($modifier =~ /([adlu])/oxms) {
6648 0 0       0 my $line = 0;
6649 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6650 0         0 if ($filename ne __FILE__) {
6651             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6652             last;
6653 0         0 }
6654             }
6655             die qq{Unsupported modifier "$1" used at line $line.\n};
6656 0         0 }
6657              
6658             $slash = 'div';
6659 122 100       259  
    100          
6660 122         492 # literal null string pattern
6661 8         9 if ($string eq '') {
6662 8         11 $modifier =~ tr/bB//d;
6663             $modifier =~ tr/i//d;
6664             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6665             }
6666              
6667             # /b /B modifier
6668             elsif ($modifier =~ tr/bB//d) {
6669 8 50       61  
6670 8         28 # choice again delimiter
6671 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6672 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6673 0         0 my %octet = map {$_ => 1} @char;
6674 0         0 if (not $octet{')'}) {
6675             $delimiter = '(';
6676             $end_delimiter = ')';
6677 0         0 }
6678 0         0 elsif (not $octet{'}'}) {
6679             $delimiter = '{';
6680             $end_delimiter = '}';
6681 0         0 }
6682 0         0 elsif (not $octet{']'}) {
6683             $delimiter = '[';
6684             $end_delimiter = ']';
6685 0         0 }
6686 0         0 elsif (not $octet{'>'}) {
6687             $delimiter = '<';
6688             $end_delimiter = '>';
6689 0         0 }
6690 0 0       0 else {
6691 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6692 0         0 if (not $octet{$char}) {
6693 0         0 $delimiter = $char;
6694             $end_delimiter = $char;
6695             last;
6696             }
6697             }
6698             }
6699 0         0 }
6700 8         16  
6701 8         13 my $prematch = '';
6702             $prematch = q{(\G[\x00-\xFF]*?)};
6703             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6704 8 100       68 }
6705 106         342  
6706             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6707             my $metachar = qr/[\@\\|[\]{^]/oxms;
6708 106         606  
6709             # split regexp
6710             my @char = $string =~ /\G((?>
6711             [^\x8E\xA1-\xFE\\\$\@\[\(]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
6712             \\ (?>[1-9][0-9]*) |
6713             \\g (?>\s*) (?>[1-9][0-9]*) |
6714             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6715             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6716             \\x (?>[0-9A-Fa-f]{1,2}) |
6717             \\ (?>[0-7]{2,3}) |
6718             \\c [\x40-\x5F] |
6719             \\x\{ (?>[0-9A-Fa-f]+) \} |
6720             \\o\{ (?>[0-7]+) \} |
6721             \\[bBNpP]\{ (?>[^\x8E\xA1-\xFE0-9\}][^\x8E\xA1-\xFE\}]*) \} |
6722             \\ $q_char |
6723             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6724             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6725             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6726             [\$\@] $qq_variable |
6727             \$ (?>\s* [0-9]+) |
6728             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6729             \$ \$ (?![\w\{]) |
6730             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6731             \[\^ |
6732             \[\: (?>[a-z]+) :\] |
6733             \[\:\^ (?>[a-z]+) :\] |
6734             \(\? |
6735             $q_char
6736             ))/oxmsg;
6737 106 50       43697  
6738 106         1249 # choice again delimiter
  0         0  
6739 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6740 0         0 my %octet = map {$_ => 1} @char;
6741 0         0 if (not $octet{')'}) {
6742             $delimiter = '(';
6743             $end_delimiter = ')';
6744 0         0 }
6745 0         0 elsif (not $octet{'}'}) {
6746             $delimiter = '{';
6747             $end_delimiter = '}';
6748 0         0 }
6749 0         0 elsif (not $octet{']'}) {
6750             $delimiter = '[';
6751             $end_delimiter = ']';
6752 0         0 }
6753 0         0 elsif (not $octet{'>'}) {
6754             $delimiter = '<';
6755             $end_delimiter = '>';
6756 0         0 }
6757 0 0       0 else {
6758 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6759 0         0 if (not $octet{$char}) {
6760 0         0 $delimiter = $char;
6761             $end_delimiter = $char;
6762             last;
6763             }
6764             }
6765             }
6766             }
6767 0         0  
  106         244  
6768             # count '('
6769 436         814 my $parens = grep { $_ eq '(' } @char;
6770 106         219  
6771 106         253 my $left_e = 0;
6772             my $right_e = 0;
6773             for (my $i=0; $i <= $#char; $i++) {
6774 106 50 33     363  
    50 33        
    100          
    100          
    50          
    50          
6775 357         2364 # "\L\u" --> "\u\L"
6776             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6777             @char[$i,$i+1] = @char[$i+1,$i];
6778             }
6779              
6780 0         0 # "\U\l" --> "\l\U"
6781             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6782             @char[$i,$i+1] = @char[$i+1,$i];
6783             }
6784              
6785 0         0 # octal escape sequence
6786             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6787             $char[$i] = Eeuctw::octchr($1);
6788             }
6789              
6790 1         4 # hexadecimal escape sequence
6791             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6792             $char[$i] = Eeuctw::hexchr($1);
6793             }
6794              
6795             # \b{...} --> b\{...}
6796             # \B{...} --> B\{...}
6797             # \N{CHARNAME} --> N\{CHARNAME}
6798             # \p{PROPERTY} --> p\{PROPERTY}
6799 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6800             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x8E\xA1-\xFE0-9\}][^\x8E\xA1-\xFE\}]*) \} ) \z/oxms) {
6801             $char[$i] = $1 . '\\' . $2;
6802             }
6803              
6804 0         0 # \p, \P, \X --> p, P, X
6805             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6806             $char[$i] = $1;
6807 0 50 100     0 }
    100 100        
    50 100        
    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          
6808              
6809             if (0) {
6810             }
6811 357         1299  
6812 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6813 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6814             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)) {
6815             $char[$i] .= join '', splice @char, $i+1, 3;
6816 0         0 }
6817             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)) {
6818             $char[$i] .= join '', splice @char, $i+1, 2;
6819 0         0 }
6820             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)) {
6821             $char[$i] .= join '', splice @char, $i+1, 1;
6822             }
6823             }
6824              
6825 0         0 # open character class [...]
6826 20 50       35 elsif ($char[$i] eq '[') {
6827 20         77 my $left = $i;
6828             if ($char[$i+1] eq ']') {
6829 0         0 $i++;
6830 20 50       29 }
6831 79         127 while (1) {
6832             if (++$i > $#char) {
6833 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6834 79         170 }
6835             if ($char[$i] eq ']') {
6836             my $right = $i;
6837 20 50       33  
6838 20         135 # [...]
  0         0  
6839             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6840             splice @char, $left, $right-$left+1, sprintf(q{@{[Eeuctw::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6841 0         0 }
6842             else {
6843             splice @char, $left, $right-$left+1, Eeuctw::charlist_qr(@char[$left+1..$right-1], $modifier);
6844 20         93 }
6845 20         44  
6846             $i = $left;
6847             last;
6848             }
6849             }
6850             }
6851              
6852 20         59 # open character class [^...]
6853 0 0       0 elsif ($char[$i] eq '[^') {
6854 0         0 my $left = $i;
6855             if ($char[$i+1] eq ']') {
6856 0         0 $i++;
6857 0 0       0 }
6858 0         0 while (1) {
6859             if (++$i > $#char) {
6860 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6861 0         0 }
6862             if ($char[$i] eq ']') {
6863             my $right = $i;
6864 0 0       0  
6865 0         0 # [^...]
  0         0  
6866             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6867             splice @char, $left, $right-$left+1, sprintf(q{@{[Eeuctw::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6868 0         0 }
6869             else {
6870             splice @char, $left, $right-$left+1, Eeuctw::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6871 0         0 }
6872 0         0  
6873             $i = $left;
6874             last;
6875             }
6876             }
6877             }
6878              
6879 0         0 # rewrite character class or escape character
6880             elsif (my $char = character_class($char[$i],$modifier)) {
6881             $char[$i] = $char;
6882             }
6883              
6884 11 50       26 # /i modifier
6885 5         16 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eeuctw::uc($char[$i]) ne Eeuctw::fc($char[$i]))) {
6886             if (CORE::length(Eeuctw::fc($char[$i])) == 1) {
6887             $char[$i] = '[' . Eeuctw::uc($char[$i]) . Eeuctw::fc($char[$i]) . ']';
6888 5         12 }
6889             else {
6890             $char[$i] = '(?:' . Eeuctw::uc($char[$i]) . '|' . Eeuctw::fc($char[$i]) . ')';
6891             }
6892             }
6893              
6894 0 50       0 # \u \l \U \L \F \Q \E
6895 8         27 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6896             if ($right_e < $left_e) {
6897             $char[$i] = '\\' . $char[$i];
6898             }
6899 0         0 }
6900 0         0 elsif ($char[$i] eq '\u') {
6901             $char[$i] = '@{[Eeuctw::ucfirst qq<';
6902             $left_e++;
6903 0         0 }
6904 0         0 elsif ($char[$i] eq '\l') {
6905             $char[$i] = '@{[Eeuctw::lcfirst qq<';
6906             $left_e++;
6907 0         0 }
6908 0         0 elsif ($char[$i] eq '\U') {
6909             $char[$i] = '@{[Eeuctw::uc qq<';
6910             $left_e++;
6911 0         0 }
6912 0         0 elsif ($char[$i] eq '\L') {
6913             $char[$i] = '@{[Eeuctw::lc qq<';
6914             $left_e++;
6915 0         0 }
6916 0         0 elsif ($char[$i] eq '\F') {
6917             $char[$i] = '@{[Eeuctw::fc qq<';
6918             $left_e++;
6919 0         0 }
6920 5         7 elsif ($char[$i] eq '\Q') {
6921             $char[$i] = '@{[CORE::quotemeta qq<';
6922             $left_e++;
6923 5 50       10 }
6924 5         10 elsif ($char[$i] eq '\E') {
6925 5         8 if ($right_e < $left_e) {
6926             $char[$i] = '>]}';
6927             $right_e++;
6928 5         10 }
6929             else {
6930             $char[$i] = '';
6931             }
6932 0         0 }
6933 0 0       0 elsif ($char[$i] eq '\Q') {
6934 0         0 while (1) {
6935             if (++$i > $#char) {
6936 0 0       0 last;
6937 0         0 }
6938             if ($char[$i] eq '\E') {
6939             last;
6940             }
6941             }
6942             }
6943             elsif ($char[$i] eq '\E') {
6944             }
6945              
6946             # \0 --> \0
6947             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6948             }
6949              
6950             # \g{N}, \g{-N}
6951              
6952             # P.108 Using Simple Patterns
6953             # in Chapter 7: In the World of Regular Expressions
6954             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6955              
6956             # P.221 Capturing
6957             # in Chapter 5: Pattern Matching
6958             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6959              
6960             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6961             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6962             }
6963              
6964 0 0       0 # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6965 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6966             if ($1 <= $parens) {
6967             $char[$i] = '\\g{' . ($1 + 1) . '}';
6968             }
6969             }
6970              
6971 0 0       0 # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6972 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6973             if ($1 <= $parens) {
6974             $char[$i] = '\\g' . ($1 + 1);
6975             }
6976             }
6977              
6978 0 0       0 # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6979 0         0 elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6980             if ($1 <= $parens) {
6981             $char[$i] = '\\' . ($1 + 1);
6982             }
6983             }
6984              
6985 0 0       0 # $0 --> $0
6986 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6987             if ($ignorecase) {
6988             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6989             }
6990 0 0       0 }
6991 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6992             if ($ignorecase) {
6993             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
6994             }
6995             }
6996              
6997             # $$ --> $$
6998             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6999             }
7000              
7001             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7002 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7003 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7004 0         0 $char[$i] = e_capture($1);
7005             if ($ignorecase) {
7006             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7007             }
7008 0         0 }
7009 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7010 0         0 $char[$i] = e_capture($1);
7011             if ($ignorecase) {
7012             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7013             }
7014             }
7015              
7016 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7017 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) {
7018 0         0 $char[$i] = e_capture($1.'->'.$2);
7019             if ($ignorecase) {
7020             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7021             }
7022             }
7023              
7024 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7025 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) {
7026 0         0 $char[$i] = e_capture($1.'->'.$2);
7027             if ($ignorecase) {
7028             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7029             }
7030             }
7031              
7032 0         0 # $$foo
7033 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7034 0         0 $char[$i] = e_capture($1);
7035             if ($ignorecase) {
7036             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7037             }
7038             }
7039              
7040 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eeuctw::PREMATCH()
7041 4         15 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7042             if ($ignorecase) {
7043             $char[$i] = '@{[Eeuctw::ignorecase(Eeuctw::PREMATCH())]}';
7044 0         0 }
7045             else {
7046             $char[$i] = '@{[Eeuctw::PREMATCH()]}';
7047             }
7048             }
7049              
7050 4 50       13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eeuctw::MATCH()
7051 4         14 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7052             if ($ignorecase) {
7053             $char[$i] = '@{[Eeuctw::ignorecase(Eeuctw::MATCH())]}';
7054 0         0 }
7055             else {
7056             $char[$i] = '@{[Eeuctw::MATCH()]}';
7057             }
7058             }
7059              
7060 4 50       13 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eeuctw::POSTMATCH()
7061 3         12 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7062             if ($ignorecase) {
7063             $char[$i] = '@{[Eeuctw::ignorecase(Eeuctw::POSTMATCH())]}';
7064 0         0 }
7065             else {
7066             $char[$i] = '@{[Eeuctw::POSTMATCH()]}';
7067             }
7068             }
7069              
7070 3 0       12 # ${ foo }
7071 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) {
7072             if ($ignorecase) {
7073             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7074             }
7075             }
7076              
7077 0         0 # ${ ... }
7078 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7079 0         0 $char[$i] = e_capture($1);
7080             if ($ignorecase) {
7081             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7082             }
7083             }
7084              
7085 0         0 # $scalar or @array
7086 9 50       25 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7087 9         46 $char[$i] = e_string($char[$i]);
7088             if ($ignorecase) {
7089             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7090             }
7091             }
7092              
7093 0 50       0 # quote character before ? + * {
7094             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7095             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7096 23         128 }
7097             else {
7098             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7099             }
7100             }
7101             }
7102 23         117  
7103 106         257 # make regexp string
7104 106         371 my $prematch = '';
7105 106 50       358 $prematch = "($anchor)";
7106 106         1566 $modifier =~ tr/i//d;
7107             if ($left_e > $right_e) {
7108 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
7109             }
7110             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
7111             }
7112              
7113             #
7114             # escape regexp (s'here'' or s'here''b)
7115 106     34 0 1377 #
7116 34   100     91 sub e_s1_q {
7117             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7118 34         109 $modifier ||= '';
7119 34 50       46  
7120 34         93 $modifier =~ tr/p//d;
7121 0         0 if ($modifier =~ /([adlu])/oxms) {
7122 0 0       0 my $line = 0;
7123 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7124 0         0 if ($filename ne __FILE__) {
7125             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7126             last;
7127 0         0 }
7128             }
7129             die qq{Unsupported modifier "$1" used at line $line.\n};
7130 0         0 }
7131              
7132             $slash = 'div';
7133 34 100       54  
    100          
7134 34         131 # literal null string pattern
7135 8         10 if ($string eq '') {
7136 8         13 $modifier =~ tr/bB//d;
7137             $modifier =~ tr/i//d;
7138             return join '', $ope, $delimiter, $end_delimiter, $modifier;
7139             }
7140              
7141 8         50 # with /b /B modifier
7142             elsif ($modifier =~ tr/bB//d) {
7143             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
7144             }
7145              
7146 8         26 # without /b /B modifier
7147             else {
7148             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
7149             }
7150             }
7151              
7152             #
7153             # escape regexp (s'here'')
7154 18     18 0 46 #
7155             sub e_s1_qt {
7156 18 100       49 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7157              
7158             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7159 18         40  
7160             # split regexp
7161             my @char = $string =~ /\G((?>
7162             [^\x8E\xA1-\xFE\\\[\$\@\/] |
7163             [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
7164             \[\^ |
7165             \[\: (?>[a-z]+) \:\] |
7166             \[\:\^ (?>[a-z]+) \:\] |
7167             [\$\@\/] |
7168             \\ (?:$q_char) |
7169             (?:$q_char)
7170             ))/oxmsg;
7171 18         471  
7172 18 50 100     71 # unescape character
    50 100        
    50 66        
    100          
    100          
    50          
7173             for (my $i=0; $i <= $#char; $i++) {
7174             if (0) {
7175             }
7176 36         175  
7177 0         0 # open character class [...]
7178 0 0       0 elsif ($char[$i] eq '[') {
7179 0         0 my $left = $i;
7180             if ($char[$i+1] eq ']') {
7181 0         0 $i++;
7182 0 0       0 }
7183 0         0 while (1) {
7184             if (++$i > $#char) {
7185 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7186 0         0 }
7187             if ($char[$i] eq ']') {
7188             my $right = $i;
7189 0         0  
7190             # [...]
7191 0         0 splice @char, $left, $right-$left+1, Eeuctw::charlist_qr(@char[$left+1..$right-1], $modifier);
7192 0         0  
7193             $i = $left;
7194             last;
7195             }
7196             }
7197             }
7198              
7199 0         0 # open character class [^...]
7200 0 0       0 elsif ($char[$i] eq '[^') {
7201 0         0 my $left = $i;
7202             if ($char[$i+1] eq ']') {
7203 0         0 $i++;
7204 0 0       0 }
7205 0         0 while (1) {
7206             if (++$i > $#char) {
7207 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7208 0         0 }
7209             if ($char[$i] eq ']') {
7210             my $right = $i;
7211 0         0  
7212             # [^...]
7213 0         0 splice @char, $left, $right-$left+1, Eeuctw::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7214 0         0  
7215             $i = $left;
7216             last;
7217             }
7218             }
7219             }
7220              
7221 0         0 # escape $ @ / and \
7222             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7223             $char[$i] = '\\' . $char[$i];
7224             }
7225              
7226 0         0 # rewrite character class or escape character
7227             elsif (my $char = character_class($char[$i],$modifier)) {
7228             $char[$i] = $char;
7229             }
7230              
7231 6 50       13 # /i modifier
7232 2         6 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eeuctw::uc($char[$i]) ne Eeuctw::fc($char[$i]))) {
7233             if (CORE::length(Eeuctw::fc($char[$i])) == 1) {
7234             $char[$i] = '[' . Eeuctw::uc($char[$i]) . Eeuctw::fc($char[$i]) . ']';
7235 2         5 }
7236             else {
7237             $char[$i] = '(?:' . Eeuctw::uc($char[$i]) . '|' . Eeuctw::fc($char[$i]) . ')';
7238             }
7239             }
7240              
7241 0 0       0 # quote character before ? + * {
7242             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7243             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7244 0         0 }
7245             else {
7246             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7247             }
7248             }
7249 0         0 }
7250 18         35  
7251 18         31 $modifier =~ tr/i//d;
7252 18         29 $delimiter = '/';
7253 18         30 $end_delimiter = '/';
7254 18         42 my $prematch = '';
7255             $prematch = "($anchor)";
7256             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
7257             }
7258              
7259             #
7260             # escape regexp (s'here''b)
7261 18     8 0 139 #
7262             sub e_s1_qb {
7263             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7264 8         22  
7265             # split regexp
7266             my @char = $string =~ /\G (?>[^\\]|\\\\|[\x00-\xFF]) /oxmsg;
7267 8         39  
7268 8 50       38 # unescape character
    50          
7269             for (my $i=0; $i <= $#char; $i++) {
7270             if (0) {
7271             }
7272 24         84  
7273             # remain \\
7274             elsif ($char[$i] eq '\\\\') {
7275             }
7276              
7277 0         0 # escape $ @ / and \
7278             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7279             $char[$i] = '\\' . $char[$i];
7280             }
7281 0         0 }
7282 8         16  
7283 8         11 $delimiter = '/';
7284 8         14 $end_delimiter = '/';
7285 8         11 my $prematch = '';
7286             $prematch = q{(\G[\x00-\xFF]*?)};
7287             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
7288             }
7289              
7290             #
7291             # escape regexp (s''here')
7292 8     29 0 62 #
7293             sub e_s2_q {
7294 29         68 my($ope,$delimiter,$end_delimiter,$string) = @_;
7295              
7296 29         42 $slash = 'div';
7297 29         254  
7298 29 100       88 my @char = $string =~ / \G (?>[^\x8E\xA1-\xFE\\]|\\\\|$q_char) /oxmsg;
    100          
7299             for (my $i=0; $i <= $#char; $i++) {
7300             if (0) {
7301             }
7302 9         33  
7303             # not escape \\
7304             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7305             }
7306              
7307 0         0 # escape $ @ / and \
7308             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7309             $char[$i] = '\\' . $char[$i];
7310             }
7311 5         15 }
7312              
7313             return join '', $ope, $delimiter, @char, $end_delimiter;
7314             }
7315              
7316             #
7317             # escape regexp (s/here/and here/modifier)
7318 29     156 0 93 #
7319 156   100     1275 sub e_sub {
7320             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7321 156         767 $modifier ||= '';
7322 156 50       378  
7323 156         495 $modifier =~ tr/p//d;
7324 0         0 if ($modifier =~ /([adlu])/oxms) {
7325 0 0       0 my $line = 0;
7326 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7327 0         0 if ($filename ne __FILE__) {
7328             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7329             last;
7330 0         0 }
7331             }
7332             die qq{Unsupported modifier "$1" used at line $line.\n};
7333 0 100       0 }
7334 156         441  
7335 37         52 if ($variable eq '') {
7336             $variable = '$_';
7337             $bind_operator = ' =~ ';
7338 37         45 }
7339              
7340             $slash = 'div';
7341              
7342             # P.128 Start of match (or end of previous match): \G
7343             # P.130 Advanced Use of \G with Perl
7344             # in Chapter 3: Overview of Regular Expression Features and Flavors
7345             # P.312 Iterative Matching: Scalar Context, with /g
7346             # in Chapter 7: Perl
7347             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7348              
7349             # P.181 Where You Left Off: The \G Assertion
7350             # in Chapter 5: Pattern Matching
7351             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7352              
7353             # P.220 Where You Left Off: The \G Assertion
7354             # in Chapter 5: Pattern Matching
7355 156         263 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7356 156         248  
7357             my $e_modifier = $modifier =~ tr/e//d;
7358 156         255 my $r_modifier = $modifier =~ tr/r//d;
7359 156 50       246  
7360 156         421 my $my = '';
7361 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7362 0         0 $my = $variable;
7363             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7364             $variable =~ s/ = .+ \z//oxms;
7365 0         0 }
7366 156         405  
7367             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7368             $variable_basename =~ s/ \s+ \z//oxms;
7369 156         331  
7370 156 100       313 # quote replacement string
7371 156         409 my $e_replacement = '';
7372 17         36 if ($e_modifier >= 1) {
7373             $e_replacement = e_qq('', '', '', $replacement);
7374             $e_modifier--;
7375 17 100       27 }
7376 139         404 else {
7377             if ($delimiter2 eq "'") {
7378             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7379 29         70 }
7380             else {
7381             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7382             }
7383 110         276 }
7384              
7385             my $sub = '';
7386 156 100       294  
7387 156 100       408 # with /r
    50          
7388             if ($r_modifier) {
7389             if (0) {
7390             }
7391 8         25  
7392 0 50       0 # s///gr with multibyte anchoring
7393             elsif ($modifier =~ /g/oxms) {
7394             $sub = sprintf(
7395             # 1 2 3 4 5
7396             q,
7397              
7398             $variable, # 1
7399             ($delimiter1 eq "'") ? # 2
7400             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7401             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7402             $s_matched, # 3
7403             $e_replacement, # 4
7404             '$Eeuctw::re_r=CORE::eval $Eeuctw::re_r; ' x $e_modifier, # 5
7405             );
7406             }
7407              
7408 4 0       20 # s///gr without multibyte anchoring
7409             elsif ($modifier =~ /g/oxms) {
7410             $sub = sprintf(
7411             # 1 2 3 4 5
7412             q,
7413              
7414             $variable, # 1
7415             ($delimiter1 eq "'") ? # 2
7416             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7417             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7418             $s_matched, # 3
7419             $e_replacement, # 4
7420             '$Eeuctw::re_r=CORE::eval $Eeuctw::re_r; ' x $e_modifier, # 5
7421             );
7422             }
7423              
7424             # s///r
7425 0         0 else {
7426 4         7  
7427             my $prematch = q{$`};
7428 4 50       5 $prematch = q{${1}};
7429              
7430             $sub = sprintf(
7431             # 1 2 3 4 5 6 7
7432             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Eeuctw::re_r=%s; %s"%s$Eeuctw::re_r$'" } : %s>,
7433              
7434             $variable, # 1
7435             ($delimiter1 eq "'") ? # 2
7436             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7437             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7438             $s_matched, # 3
7439             $e_replacement, # 4
7440             '$Eeuctw::re_r=CORE::eval $Eeuctw::re_r; ' x $e_modifier, # 5
7441             $prematch, # 6
7442             $variable, # 7
7443             );
7444             }
7445 4 50       14  
7446 8         28 # $var !~ s///r doesn't make sense
7447             if ($bind_operator =~ / !~ /oxms) {
7448             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7449             }
7450             }
7451              
7452 0 100       0 # without /r
    50          
7453             else {
7454             if (0) {
7455             }
7456 148         523  
7457 0 100       0 # s///g with multibyte anchoring
    100          
7458             elsif ($modifier =~ /g/oxms) {
7459             $sub = sprintf(
7460             # 1 2 3 4 5 6 7 8 9 10
7461             q,
7462              
7463             $variable, # 1
7464             ($delimiter1 eq "'") ? # 2
7465             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7466             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7467             $s_matched, # 3
7468             $e_replacement, # 4
7469             '$Eeuctw::re_r=CORE::eval $Eeuctw::re_r; ' x $e_modifier, # 5
7470             $variable, # 6
7471             $variable, # 7
7472             $variable, # 8
7473             $variable, # 9
7474              
7475             # Binary "!~" is just like "=~" except the return value is negated in the logical sense.
7476             # It returns false if the match succeeds, and true if it fails.
7477             # (and so on)
7478              
7479             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 10
7480             );
7481             }
7482              
7483 29 0       139 # s///g without multibyte anchoring
    0          
7484             elsif ($modifier =~ /g/oxms) {
7485             $sub = sprintf(
7486             # 1 2 3 4 5 6 7 8
7487             q,
7488              
7489             $variable, # 1
7490             ($delimiter1 eq "'") ? # 2
7491             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7492             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7493             $s_matched, # 3
7494             $e_replacement, # 4
7495             '$Eeuctw::re_r=CORE::eval $Eeuctw::re_r; ' x $e_modifier, # 5
7496             $variable, # 6
7497             $variable, # 7
7498             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7499             );
7500             }
7501              
7502             # s///
7503 0         0 else {
7504 119         633  
7505             my $prematch = q{$`};
7506 119 100       210 $prematch = q{${1}};
    100          
7507              
7508             $sub = sprintf(
7509              
7510             ($bind_operator =~ / =~ /oxms) ?
7511              
7512             # 1 2 3 4 5 6 7 8
7513             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Eeuctw::re_r=%s; %s%s="%s$Eeuctw::re_r$'"; 1 } : undef> :
7514              
7515             # 1 2 3 4 5 6 7 8
7516             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Eeuctw::re_r=%s; %s%s="%s$Eeuctw::re_r$'"; undef }>,
7517              
7518             $variable, # 1
7519             $bind_operator, # 2
7520             ($delimiter1 eq "'") ? # 3
7521             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7522             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7523             $s_matched, # 4
7524             $e_replacement, # 5
7525             '$Eeuctw::re_r=CORE::eval $Eeuctw::re_r; ' x $e_modifier, # 6
7526             $variable, # 7
7527             $prematch, # 8
7528             );
7529             }
7530             }
7531 119 50       709  
7532 156         491 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7533             if ($my ne '') {
7534             $sub = "($my, $sub)[1]";
7535             }
7536 0         0  
7537 156         291 # clear s/// variable
7538             $sub_variable = '';
7539 156         253 $bind_operator = '';
7540              
7541             return $sub;
7542             }
7543              
7544             #
7545             # escape regexp of split qr//
7546 156     143 0 1654 #
7547 143   100     687 sub e_split {
7548             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7549 143         605 $modifier ||= '';
7550 143 50       312  
7551 143         394 $modifier =~ tr/p//d;
7552 0         0 if ($modifier =~ /([adlu])/oxms) {
7553 0 0       0 my $line = 0;
7554 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7555 0         0 if ($filename ne __FILE__) {
7556             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7557             last;
7558 0         0 }
7559             }
7560             die qq{Unsupported modifier "$1" used at line $line.\n};
7561 0         0 }
7562              
7563             $slash = 'div';
7564 143 100       251  
7565 143         318 # /b /B modifier
7566             if ($modifier =~ tr/bB//d) {
7567             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7568 18 100       105 }
7569 125         298  
7570             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7571             my $metachar = qr/[\@\\|[\]{^]/oxms;
7572 125         453  
7573             # split regexp
7574             my @char = $string =~ /\G((?>
7575             [^\x8E\xA1-\xFE\\\$\@\[\(]|[\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
7576             \\x (?>[0-9A-Fa-f]{1,2}) |
7577             \\ (?>[0-7]{2,3}) |
7578             \\c [\x40-\x5F] |
7579             \\x\{ (?>[0-9A-Fa-f]+) \} |
7580             \\o\{ (?>[0-7]+) \} |
7581             \\[bBNpP]\{ (?>[^\x8E\xA1-\xFE0-9\}][^\x8E\xA1-\xFE\}]*) \} |
7582             \\ $q_char |
7583             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7584             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7585             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7586             [\$\@] $qq_variable |
7587             \$ (?>\s* [0-9]+) |
7588             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7589             \$ \$ (?![\w\{]) |
7590             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7591             \[\^ |
7592             \[\: (?>[a-z]+) :\] |
7593             \[\:\^ (?>[a-z]+) :\] |
7594             \(\? |
7595             $q_char
7596 125         19132 ))/oxmsg;
7597 125         706  
7598 125         192 my $left_e = 0;
7599             my $right_e = 0;
7600             for (my $i=0; $i <= $#char; $i++) {
7601 125 50 33     416  
    50 33        
    100          
    100          
    50          
    50          
7602 308         1943 # "\L\u" --> "\u\L"
7603             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7604             @char[$i,$i+1] = @char[$i+1,$i];
7605             }
7606              
7607 0         0 # "\U\l" --> "\l\U"
7608             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7609             @char[$i,$i+1] = @char[$i+1,$i];
7610             }
7611              
7612 0         0 # octal escape sequence
7613             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7614             $char[$i] = Eeuctw::octchr($1);
7615             }
7616              
7617 1         4 # hexadecimal escape sequence
7618             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7619             $char[$i] = Eeuctw::hexchr($1);
7620             }
7621              
7622             # \b{...} --> b\{...}
7623             # \B{...} --> B\{...}
7624             # \N{CHARNAME} --> N\{CHARNAME}
7625             # \p{PROPERTY} --> p\{PROPERTY}
7626 1         3 # \P{PROPERTY} --> P\{PROPERTY}
7627             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x8E\xA1-\xFE0-9\}][^\x8E\xA1-\xFE\}]*) \} ) \z/oxms) {
7628             $char[$i] = $1 . '\\' . $2;
7629             }
7630              
7631 0         0 # \p, \P, \X --> p, P, X
7632             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7633             $char[$i] = $1;
7634 0 50 100     0 }
    100 100        
    100 66        
    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          
7635              
7636             if (0) {
7637             }
7638 308         1135  
7639 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7640 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7641             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)) {
7642             $char[$i] .= join '', splice @char, $i+1, 3;
7643 0         0 }
7644             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)) {
7645             $char[$i] .= join '', splice @char, $i+1, 2;
7646 0         0 }
7647             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)) {
7648             $char[$i] .= join '', splice @char, $i+1, 1;
7649             }
7650             }
7651              
7652 0         0 # open character class [...]
7653 3 50       7 elsif ($char[$i] eq '[') {
7654 3         9 my $left = $i;
7655             if ($char[$i+1] eq ']') {
7656 0         0 $i++;
7657 3 50       6 }
7658 7         24 while (1) {
7659             if (++$i > $#char) {
7660 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7661 7         62 }
7662             if ($char[$i] eq ']') {
7663             my $right = $i;
7664 3 50       5  
7665 3         19 # [...]
  0         0  
7666             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7667             splice @char, $left, $right-$left+1, sprintf(q{@{[Eeuctw::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7668 0         0 }
7669             else {
7670             splice @char, $left, $right-$left+1, Eeuctw::charlist_qr(@char[$left+1..$right-1], $modifier);
7671 3         16 }
7672 3         8  
7673             $i = $left;
7674             last;
7675             }
7676             }
7677             }
7678              
7679 3         7 # open character class [^...]
7680 1 50       3 elsif ($char[$i] eq '[^') {
7681 1         4 my $left = $i;
7682             if ($char[$i+1] eq ']') {
7683 0         0 $i++;
7684 1 50       2 }
7685 2         7 while (1) {
7686             if (++$i > $#char) {
7687 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7688 2         5 }
7689             if ($char[$i] eq ']') {
7690             my $right = $i;
7691 1 50       2  
7692 1         10 # [^...]
  0         0  
7693             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7694             splice @char, $left, $right-$left+1, sprintf(q{@{[Eeuctw::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7695 0         0 }
7696             else {
7697             splice @char, $left, $right-$left+1, Eeuctw::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7698 1         6 }
7699 1         3  
7700             $i = $left;
7701             last;
7702             }
7703             }
7704             }
7705              
7706 1         2 # rewrite character class or escape character
7707             elsif (my $char = character_class($char[$i],$modifier)) {
7708             $char[$i] = $char;
7709             }
7710              
7711             # P.794 29.2.161. split
7712             # in Chapter 29: Functions
7713             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7714              
7715             # P.951 split
7716             # in Chapter 27: Functions
7717             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7718              
7719             # said "The //m modifier is assumed when you split on the pattern /^/",
7720             # but perl5.008 is not so. Therefore, this software adds //m.
7721             # (and so on)
7722              
7723 5         13 # split(m/^/) --> split(m/^/m)
7724             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7725             $modifier .= 'm';
7726             }
7727              
7728 11 50       43 # /i modifier
7729 6         19 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eeuctw::uc($char[$i]) ne Eeuctw::fc($char[$i]))) {
7730             if (CORE::length(Eeuctw::fc($char[$i])) == 1) {
7731             $char[$i] = '[' . Eeuctw::uc($char[$i]) . Eeuctw::fc($char[$i]) . ']';
7732 6         15 }
7733             else {
7734             $char[$i] = '(?:' . Eeuctw::uc($char[$i]) . '|' . Eeuctw::fc($char[$i]) . ')';
7735             }
7736             }
7737              
7738 0 50       0 # \u \l \U \L \F \Q \E
7739 2         9 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7740             if ($right_e < $left_e) {
7741             $char[$i] = '\\' . $char[$i];
7742             }
7743 0         0 }
7744 0         0 elsif ($char[$i] eq '\u') {
7745             $char[$i] = '@{[Eeuctw::ucfirst qq<';
7746             $left_e++;
7747 0         0 }
7748 0         0 elsif ($char[$i] eq '\l') {
7749             $char[$i] = '@{[Eeuctw::lcfirst qq<';
7750             $left_e++;
7751 0         0 }
7752 0         0 elsif ($char[$i] eq '\U') {
7753             $char[$i] = '@{[Eeuctw::uc qq<';
7754             $left_e++;
7755 0         0 }
7756 0         0 elsif ($char[$i] eq '\L') {
7757             $char[$i] = '@{[Eeuctw::lc qq<';
7758             $left_e++;
7759 0         0 }
7760 0         0 elsif ($char[$i] eq '\F') {
7761             $char[$i] = '@{[Eeuctw::fc qq<';
7762             $left_e++;
7763 0         0 }
7764 0         0 elsif ($char[$i] eq '\Q') {
7765             $char[$i] = '@{[CORE::quotemeta qq<';
7766             $left_e++;
7767 0 0       0 }
7768 0         0 elsif ($char[$i] eq '\E') {
7769 0         0 if ($right_e < $left_e) {
7770             $char[$i] = '>]}';
7771             $right_e++;
7772 0         0 }
7773             else {
7774             $char[$i] = '';
7775             }
7776 0         0 }
7777 0 0       0 elsif ($char[$i] eq '\Q') {
7778 0         0 while (1) {
7779             if (++$i > $#char) {
7780 0 0       0 last;
7781 0         0 }
7782             if ($char[$i] eq '\E') {
7783             last;
7784             }
7785             }
7786             }
7787             elsif ($char[$i] eq '\E') {
7788             }
7789              
7790 0 0       0 # $0 --> $0
7791 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7792             if ($ignorecase) {
7793             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7794             }
7795 0 0       0 }
7796 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7797             if ($ignorecase) {
7798             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7799             }
7800             }
7801              
7802             # $$ --> $$
7803             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7804             }
7805              
7806             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7807 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7808 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7809 0         0 $char[$i] = e_capture($1);
7810             if ($ignorecase) {
7811             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7812             }
7813 0         0 }
7814 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7815 0         0 $char[$i] = e_capture($1);
7816             if ($ignorecase) {
7817             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7818             }
7819             }
7820              
7821 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7822 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) {
7823 0         0 $char[$i] = e_capture($1.'->'.$2);
7824             if ($ignorecase) {
7825             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7826             }
7827             }
7828              
7829 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7830 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) {
7831 0         0 $char[$i] = e_capture($1.'->'.$2);
7832             if ($ignorecase) {
7833             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7834             }
7835             }
7836              
7837 0         0 # $$foo
7838 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7839 0         0 $char[$i] = e_capture($1);
7840             if ($ignorecase) {
7841             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7842             }
7843             }
7844              
7845 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eeuctw::PREMATCH()
7846 12         41 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7847             if ($ignorecase) {
7848             $char[$i] = '@{[Eeuctw::ignorecase(Eeuctw::PREMATCH())]}';
7849 0         0 }
7850             else {
7851             $char[$i] = '@{[Eeuctw::PREMATCH()]}';
7852             }
7853             }
7854              
7855 12 50       60 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eeuctw::MATCH()
7856 12         59 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7857             if ($ignorecase) {
7858             $char[$i] = '@{[Eeuctw::ignorecase(Eeuctw::MATCH())]}';
7859 0         0 }
7860             else {
7861             $char[$i] = '@{[Eeuctw::MATCH()]}';
7862             }
7863             }
7864              
7865 12 50       65 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eeuctw::POSTMATCH()
7866 9         31 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7867             if ($ignorecase) {
7868             $char[$i] = '@{[Eeuctw::ignorecase(Eeuctw::POSTMATCH())]}';
7869 0         0 }
7870             else {
7871             $char[$i] = '@{[Eeuctw::POSTMATCH()]}';
7872             }
7873             }
7874              
7875 9 0       45 # ${ foo }
7876 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) {
7877             if ($ignorecase) {
7878             $char[$i] = '@{[Eeuctw::ignorecase(' . $1 . ')]}';
7879             }
7880             }
7881              
7882 0         0 # ${ ... }
7883 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7884 0         0 $char[$i] = e_capture($1);
7885             if ($ignorecase) {
7886             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7887             }
7888             }
7889              
7890 0         0 # $scalar or @array
7891 3 50       9 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7892 3         14 $char[$i] = e_string($char[$i]);
7893             if ($ignorecase) {
7894             $char[$i] = '@{[Eeuctw::ignorecase(' . $char[$i] . ')]}';
7895             }
7896             }
7897              
7898 0 100       0 # quote character before ? + * {
7899             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7900             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7901 7         38 }
7902             else {
7903             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7904             }
7905             }
7906             }
7907 4         22  
7908 125 50       256 # make regexp string
7909 125         363 $modifier =~ tr/i//d;
7910             if ($left_e > $right_e) {
7911 0         0 return join '', 'Eeuctw::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7912             }
7913             return join '', 'Eeuctw::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7914             }
7915              
7916             #
7917             # escape regexp of split qr''
7918 125     24 0 1359 #
7919 24   100     128 sub e_split_q {
7920             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7921 24         75 $modifier ||= '';
7922 24 50       49  
7923 24         73 $modifier =~ tr/p//d;
7924 0         0 if ($modifier =~ /([adlu])/oxms) {
7925 0 0       0 my $line = 0;
7926 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7927 0         0 if ($filename ne __FILE__) {
7928             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7929             last;
7930 0         0 }
7931             }
7932             die qq{Unsupported modifier "$1" used at line $line.\n};
7933 0         0 }
7934              
7935             $slash = 'div';
7936 24 100       41  
7937 24         59 # /b /B modifier
7938             if ($modifier =~ tr/bB//d) {
7939             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7940 12 100       60 }
7941              
7942             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7943 12         40  
7944             # split regexp
7945             my @char = $string =~ /\G((?>
7946             [^\x8E\xA1-\xFE\\\[] |
7947             [\xA1-\xFE][\xA1-\xFE]|\x8E[\xA1-\xB0][\xA1-\xFE][\x00-\xFF] |
7948             \[\^ |
7949             \[\: (?>[a-z]+) \:\] |
7950             \[\:\^ (?>[a-z]+) \:\] |
7951             \\ (?:$q_char) |
7952             (?:$q_char)
7953             ))/oxmsg;
7954 12         189  
7955 12 50 33     42 # unescape character
    50 100        
    50 66        
    50 33        
    100          
    50          
7956             for (my $i=0; $i <= $#char; $i++) {
7957             if (0) {
7958             }
7959 12         63  
7960 0         0 # open character class [...]
7961 0 0       0 elsif ($char[$i] eq '[') {
7962 0         0 my $left = $i;
7963             if ($char[$i+1] eq ']') {
7964 0         0 $i++;
7965 0 0       0 }
7966 0         0 while (1) {
7967             if (++$i > $#char) {
7968 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7969 0         0 }
7970             if ($char[$i] eq ']') {
7971             my $right = $i;
7972 0         0  
7973             # [...]
7974 0         0 splice @char, $left, $right-$left+1, Eeuctw::charlist_qr(@char[$left+1..$right-1], $modifier);
7975 0         0  
7976             $i = $left;
7977             last;
7978             }
7979             }
7980             }
7981              
7982 0         0 # open character class [^...]
7983 0 0       0 elsif ($char[$i] eq '[^') {
7984 0         0 my $left = $i;
7985             if ($char[$i+1] eq ']') {
7986 0         0 $i++;
7987 0 0       0 }
7988 0         0 while (1) {
7989             if (++$i > $#char) {
7990 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7991 0         0 }
7992             if ($char[$i] eq ']') {
7993             my $right = $i;
7994 0         0  
7995             # [^...]
7996 0         0 splice @char, $left, $right-$left+1, Eeuctw::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7997 0         0  
7998             $i = $left;
7999             last;
8000             }
8001             }
8002             }
8003              
8004 0         0 # rewrite character class or escape character
8005             elsif (my $char = character_class($char[$i],$modifier)) {
8006             $char[$i] = $char;
8007             }
8008              
8009 0         0 # split(m/^/) --> split(m/^/m)
8010             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
8011             $modifier .= 'm';
8012             }
8013              
8014 0 50       0 # /i modifier
8015 4         12 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eeuctw::uc($char[$i]) ne Eeuctw::fc($char[$i]))) {
8016             if (CORE::length(Eeuctw::fc($char[$i])) == 1) {
8017             $char[$i] = '[' . Eeuctw::uc($char[$i]) . Eeuctw::fc($char[$i]) . ']';
8018 4         13 }
8019             else {
8020             $char[$i] = '(?:' . Eeuctw::uc($char[$i]) . '|' . Eeuctw::fc($char[$i]) . ')';
8021             }
8022             }
8023              
8024 0 0       0 # quote character before ? + * {
8025             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
8026             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
8027 0         0 }
8028             else {
8029             $char[$i-1] = '(?:' . $char[$i-1] . ')';
8030             }
8031             }
8032 0         0 }
8033 12         27  
8034             $modifier =~ tr/i//d;
8035             return join '', 'Eeuctw::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
8036             }
8037              
8038             #
8039             # instead of Carp::carp
8040 12     0 0 86 #
8041 0           sub carp {
8042             my($package,$filename,$line) = caller(1);
8043             print STDERR "@_ at $filename line $line.\n";
8044             }
8045              
8046             #
8047             # instead of Carp::croak
8048 0     0 0   #
8049 0           sub croak {
8050 0           my($package,$filename,$line) = caller(1);
8051             print STDERR "@_ at $filename line $line.\n";
8052             die "\n";
8053             }
8054              
8055             #
8056             # instead of Carp::cluck
8057 0     0 0   #
8058 0           sub cluck {
8059 0           my $i = 0;
8060 0           my @cluck = ();
8061 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
8062             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
8063 0           $i++;
8064 0           }
8065 0           print STDERR CORE::reverse @cluck;
8066             print STDERR "\n";
8067             print STDERR @_;
8068             }
8069              
8070             #
8071             # instead of Carp::confess
8072 0     0 0   #
8073 0           sub confess {
8074 0           my $i = 0;
8075 0           my @confess = ();
8076 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
8077             push @confess, "[$i] $filename($line) $package::$subroutine\n";
8078 0           $i++;
8079 0           }
8080 0           print STDERR CORE::reverse @confess;
8081 0           print STDERR "\n";
8082             print STDERR @_;
8083             die "\n";
8084             }
8085              
8086             1;
8087              
8088             __END__