File Coverage

blib/lib/Eusascii.pm
Criterion Covered Total %
statement 896 3196 28.0
branch 962 2742 35.0
condition 97 355 27.3
subroutine 52 110 47.2
pod 7 74 9.4
total 2014 6477 31.0


line stmt bran cond sub pod time code
1             package Eusascii;
2 204     204   1151 use strict;
  204         328  
  204         5327  
3             ######################################################################
4             #
5             # Eusascii - Run-time routines for USASCII.pm
6             #
7             # http://search.cpan.org/dist/Char-USASCII/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   2773 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         587  
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 204     204   895 use vars qw($VERSION);
  204         337  
  204         26210  
28             $VERSION = '1.15';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1458 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         347 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         24989 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 204     204   12850 CORE::eval q{
  204     204   1146  
  204     80   395  
  204         21137  
  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 204 50       70175 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 (Eusascii::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Eusascii::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 204     204   1592 no strict qw(refs);
  204         372  
  204         13326  
118 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 204     204   1234 no strict qw(refs);
  204     0   392  
  204         33505  
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{[\x00-\xFF]};
153 204     204   1356 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         363  
  204         12145  
154 204     204   1229 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         510  
  204         157614  
155              
156             #
157             # US-ASCII character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # US-ASCII 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 Eusascii \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0xFF],
180             ],
181             );
182             }
183              
184             else {
185             croak "Don't know my package name '@{[__PACKAGE__]}'";
186             }
187              
188             #
189             # @ARGV wildcard globbing
190             #
191             sub import {
192              
193 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
194 0         0 my @argv = ();
195 0         0 for (@ARGV) {
196              
197             # has space
198 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
199 0 0       0 if (my @glob = Eusascii::glob(qq{"$_"})) {
200 0         0 push @argv, @glob;
201             }
202             else {
203 0         0 push @argv, $_;
204             }
205             }
206              
207             # has wildcard metachar
208             elsif (/\A (?:$q_char)*? [*?] /oxms) {
209 0 0       0 if (my @glob = Eusascii::glob($_)) {
210 0         0 push @argv, @glob;
211             }
212             else {
213 0         0 push @argv, $_;
214             }
215             }
216              
217             # no wildcard globbing
218             else {
219 0         0 push @argv, $_;
220             }
221             }
222 0         0 @ARGV = @argv;
223             }
224              
225 0         0 *Char::ord = \&USASCII::ord;
226 0         0 *Char::ord_ = \&USASCII::ord_;
227 0         0 *Char::reverse = \&USASCII::reverse;
228 0         0 *Char::getc = \&USASCII::getc;
229 0         0 *Char::length = \&USASCII::length;
230 0         0 *Char::substr = \&USASCII::substr;
231 0         0 *Char::index = \&USASCII::index;
232 0         0 *Char::rindex = \&USASCII::rindex;
233 0         0 *Char::eval = \&USASCII::eval;
234 0         0 *Char::escape = \&USASCII::escape;
235 0         0 *Char::escape_token = \&USASCII::escape_token;
236 0         0 *Char::escape_script = \&USASCII::escape_script;
237             }
238              
239             # P.230 Care with Prototypes
240             # in Chapter 6: Subroutines
241             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
242             #
243             # If you aren't careful, you can get yourself into trouble with prototypes.
244             # But if you are careful, you can do a lot of neat things with them. This is
245             # all very powerful, of course, and should only be used in moderation to make
246             # the world a better place.
247              
248             # P.332 Care with Prototypes
249             # in Chapter 7: Subroutines
250             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
251             #
252             # If you aren't careful, you can get yourself into trouble with prototypes.
253             # But if you are careful, you can do a lot of neat things with them. This is
254             # all very powerful, of course, and should only be used in moderation to make
255             # the world a better place.
256              
257             #
258             # Prototypes of subroutines
259             #
260       0     sub unimport {}
261             sub Eusascii::split(;$$$);
262             sub Eusascii::tr($$$$;$);
263             sub Eusascii::chop(@);
264             sub Eusascii::index($$;$);
265             sub Eusascii::rindex($$;$);
266             sub Eusascii::lcfirst(@);
267             sub Eusascii::lcfirst_();
268             sub Eusascii::lc(@);
269             sub Eusascii::lc_();
270             sub Eusascii::ucfirst(@);
271             sub Eusascii::ucfirst_();
272             sub Eusascii::uc(@);
273             sub Eusascii::uc_();
274             sub Eusascii::fc(@);
275             sub Eusascii::fc_();
276             sub Eusascii::ignorecase;
277             sub Eusascii::classic_character_class;
278             sub Eusascii::capture;
279             sub Eusascii::chr(;$);
280             sub Eusascii::chr_();
281             sub Eusascii::glob($);
282             sub Eusascii::glob_();
283              
284             sub USASCII::ord(;$);
285             sub USASCII::ord_();
286             sub USASCII::reverse(@);
287             sub USASCII::getc(;*@);
288             sub USASCII::length(;$);
289             sub USASCII::substr($$;$$);
290             sub USASCII::index($$;$);
291             sub USASCII::rindex($$;$);
292             sub USASCII::escape(;$);
293              
294             #
295             # Regexp work
296             #
297 204         20007 use vars qw(
298             $re_a
299             $re_t
300             $re_n
301             $re_r
302 204     204   1420 );
  204         390  
303              
304             #
305             # Character class
306             #
307 204         1698021 use vars qw(
308             $dot
309             $dot_s
310             $eD
311             $eS
312             $eW
313             $eH
314             $eV
315             $eR
316             $eN
317             $not_alnum
318             $not_alpha
319             $not_ascii
320             $not_blank
321             $not_cntrl
322             $not_digit
323             $not_graph
324             $not_lower
325             $not_lower_i
326             $not_print
327             $not_punct
328             $not_space
329             $not_upper
330             $not_upper_i
331             $not_word
332             $not_xdigit
333             $eb
334             $eB
335 204     204   1227 );
  204         387  
336              
337             ${Eusascii::dot} = qr{(?>[^\x0A])};
338             ${Eusascii::dot_s} = qr{(?>[\x00-\xFF])};
339             ${Eusascii::eD} = qr{(?>[^0-9])};
340              
341             # Vertical tabs are now whitespace
342             # \s in a regex now matches a vertical tab in all circumstances.
343             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
344             # ${Eusascii::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
345             # ${Eusascii::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
346             ${Eusascii::eS} = qr{(?>[^\s])};
347              
348             ${Eusascii::eW} = qr{(?>[^0-9A-Z_a-z])};
349             ${Eusascii::eH} = qr{(?>[^\x09\x20])};
350             ${Eusascii::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
351             ${Eusascii::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
352             ${Eusascii::eN} = qr{(?>[^\x0A])};
353             ${Eusascii::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
354             ${Eusascii::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
355             ${Eusascii::not_ascii} = qr{(?>[^\x00-\x7F])};
356             ${Eusascii::not_blank} = qr{(?>[^\x09\x20])};
357             ${Eusascii::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
358             ${Eusascii::not_digit} = qr{(?>[^\x30-\x39])};
359             ${Eusascii::not_graph} = qr{(?>[^\x21-\x7F])};
360             ${Eusascii::not_lower} = qr{(?>[^\x61-\x7A])};
361             ${Eusascii::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
362             # ${Eusascii::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
363             ${Eusascii::not_print} = qr{(?>[^\x20-\x7F])};
364             ${Eusascii::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
365             ${Eusascii::not_space} = qr{(?>[^\s\x0B])};
366             ${Eusascii::not_upper} = qr{(?>[^\x41-\x5A])};
367             ${Eusascii::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
368             # ${Eusascii::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
369             ${Eusascii::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
370             ${Eusascii::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
371             ${Eusascii::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))};
372             ${Eusascii::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]))};
373              
374             # avoid: Name "Eusascii::foo" used only once: possible typo at here.
375             ${Eusascii::dot} = ${Eusascii::dot};
376             ${Eusascii::dot_s} = ${Eusascii::dot_s};
377             ${Eusascii::eD} = ${Eusascii::eD};
378             ${Eusascii::eS} = ${Eusascii::eS};
379             ${Eusascii::eW} = ${Eusascii::eW};
380             ${Eusascii::eH} = ${Eusascii::eH};
381             ${Eusascii::eV} = ${Eusascii::eV};
382             ${Eusascii::eR} = ${Eusascii::eR};
383             ${Eusascii::eN} = ${Eusascii::eN};
384             ${Eusascii::not_alnum} = ${Eusascii::not_alnum};
385             ${Eusascii::not_alpha} = ${Eusascii::not_alpha};
386             ${Eusascii::not_ascii} = ${Eusascii::not_ascii};
387             ${Eusascii::not_blank} = ${Eusascii::not_blank};
388             ${Eusascii::not_cntrl} = ${Eusascii::not_cntrl};
389             ${Eusascii::not_digit} = ${Eusascii::not_digit};
390             ${Eusascii::not_graph} = ${Eusascii::not_graph};
391             ${Eusascii::not_lower} = ${Eusascii::not_lower};
392             ${Eusascii::not_lower_i} = ${Eusascii::not_lower_i};
393             ${Eusascii::not_print} = ${Eusascii::not_print};
394             ${Eusascii::not_punct} = ${Eusascii::not_punct};
395             ${Eusascii::not_space} = ${Eusascii::not_space};
396             ${Eusascii::not_upper} = ${Eusascii::not_upper};
397             ${Eusascii::not_upper_i} = ${Eusascii::not_upper_i};
398             ${Eusascii::not_word} = ${Eusascii::not_word};
399             ${Eusascii::not_xdigit} = ${Eusascii::not_xdigit};
400             ${Eusascii::eb} = ${Eusascii::eb};
401             ${Eusascii::eB} = ${Eusascii::eB};
402              
403             #
404             # US-ASCII split
405             #
406             sub Eusascii::split(;$$$) {
407              
408             # P.794 29.2.161. split
409             # in Chapter 29: Functions
410             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
411              
412             # P.951 split
413             # in Chapter 27: Functions
414             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
415              
416 0     0 0 0 my $pattern = $_[0];
417 0         0 my $string = $_[1];
418 0         0 my $limit = $_[2];
419              
420             # if $pattern is also omitted or is the literal space, " "
421 0 0       0 if (not defined $pattern) {
422 0         0 $pattern = ' ';
423             }
424              
425             # if $string is omitted, the function splits the $_ string
426 0 0       0 if (not defined $string) {
427 0 0       0 if (defined $_) {
428 0         0 $string = $_;
429             }
430             else {
431 0         0 $string = '';
432             }
433             }
434              
435 0         0 my @split = ();
436              
437             # when string is empty
438 0 0       0 if ($string eq '') {
    0          
439              
440             # resulting list value in list context
441 0 0       0 if (wantarray) {
442 0         0 return @split;
443             }
444              
445             # count of substrings in scalar context
446             else {
447 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
448 0         0 @_ = @split;
449 0         0 return scalar @_;
450             }
451             }
452              
453             # split's first argument is more consistently interpreted
454             #
455             # After some changes earlier in v5.17, split's behavior has been simplified:
456             # if the PATTERN argument evaluates to a string containing one space, it is
457             # treated the way that a literal string containing one space once was.
458             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
459              
460             # if $pattern is also omitted or is the literal space, " ", the function splits
461             # on whitespace, /\s+/, after skipping any leading whitespace
462             # (and so on)
463              
464             elsif ($pattern eq ' ') {
465 0 0       0 if (not defined $limit) {
466 0         0 return CORE::split(' ', $string);
467             }
468             else {
469 0         0 return CORE::split(' ', $string, $limit);
470             }
471             }
472              
473             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
474 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
475              
476             # a pattern capable of matching either the null string or something longer than the
477             # null string will split the value of $string into separate characters wherever it
478             # matches the null string between characters
479             # (and so on)
480              
481 0 0       0 if ('' =~ / \A $pattern \z /xms) {
482 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
483 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
484              
485             # P.1024 Appendix W.10 Multibyte Processing
486             # of ISBN 1-56592-224-7 CJKV Information Processing
487             # (and so on)
488              
489             # the //m modifier is assumed when you split on the pattern /^/
490             # (and so on)
491              
492             # V
493 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
494              
495             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
496             # is included in the resulting list, interspersed with the fields that are ordinarily returned
497             # (and so on)
498              
499 0         0 local $@;
500 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
501 0         0 push @split, CORE::eval('$' . $digit);
502             }
503             }
504             }
505              
506             else {
507 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
508              
509             # V
510 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
511 0         0 local $@;
512 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
513 0         0 push @split, CORE::eval('$' . $digit);
514             }
515             }
516             }
517             }
518              
519             elsif ($limit > 0) {
520 0 0       0 if ('' =~ / \A $pattern \z /xms) {
521 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
522 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
523              
524             # V
525 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
526 0         0 local $@;
527 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
528 0         0 push @split, CORE::eval('$' . $digit);
529             }
530             }
531             }
532             }
533             else {
534 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
535 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
536              
537             # V
538 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
539 0         0 local $@;
540 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
541 0         0 push @split, CORE::eval('$' . $digit);
542             }
543             }
544             }
545             }
546             }
547              
548 0 0       0 if (CORE::length($string) > 0) {
549 0         0 push @split, $string;
550             }
551              
552             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
553 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
554 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
555 0         0 pop @split;
556             }
557             }
558              
559             # resulting list value in list context
560 0 0       0 if (wantarray) {
561 0         0 return @split;
562             }
563              
564             # count of substrings in scalar context
565             else {
566 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
567 0         0 @_ = @split;
568 0         0 return scalar @_;
569             }
570             }
571              
572             #
573             # get last subexpression offsets
574             #
575             sub _last_subexpression_offsets {
576 0     0   0 my $pattern = $_[0];
577              
578             # remove comment
579 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
580              
581 0         0 my $modifier = '';
582 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
583 0         0 $modifier = $1;
584 0         0 $modifier =~ s/-[A-Za-z]*//;
585             }
586              
587             # with /x modifier
588 0         0 my @char = ();
589 0 0       0 if ($modifier =~ /x/oxms) {
590 0         0 @char = $pattern =~ /\G((?>
591             [^\\\#\[\(] |
592             \\ $q_char |
593             \# (?>[^\n]*) $ |
594             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
595             \(\? |
596             $q_char
597             ))/oxmsg;
598             }
599              
600             # without /x modifier
601             else {
602 0         0 @char = $pattern =~ /\G((?>
603             [^\\\[\(] |
604             \\ $q_char |
605             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
606             \(\? |
607             $q_char
608             ))/oxmsg;
609             }
610              
611 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
612             }
613              
614             #
615             # US-ASCII transliteration (tr///)
616             #
617             sub Eusascii::tr($$$$;$) {
618              
619 0     0 0 0 my $bind_operator = $_[1];
620 0         0 my $searchlist = $_[2];
621 0         0 my $replacementlist = $_[3];
622 0   0     0 my $modifier = $_[4] || '';
623              
624 0 0       0 if ($modifier =~ /r/oxms) {
625 0 0       0 if ($bind_operator =~ / !~ /oxms) {
626 0         0 croak "Using !~ with tr///r doesn't make sense";
627             }
628             }
629              
630 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
631 0         0 my @searchlist = _charlist_tr($searchlist);
632 0         0 my @replacementlist = _charlist_tr($replacementlist);
633              
634 0         0 my %tr = ();
635 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
636 0 0       0 if (not exists $tr{$searchlist[$i]}) {
637 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
638 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
639             }
640             elsif ($modifier =~ /d/oxms) {
641 0         0 $tr{$searchlist[$i]} = '';
642             }
643             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
644 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
645             }
646             else {
647 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
648             }
649             }
650             }
651              
652 0         0 my $tr = 0;
653 0         0 my $replaced = '';
654 0 0       0 if ($modifier =~ /c/oxms) {
655 0         0 while (defined(my $char = shift @char)) {
656 0 0       0 if (not exists $tr{$char}) {
657 0 0       0 if (defined $replacementlist[0]) {
658 0         0 $replaced .= $replacementlist[0];
659             }
660 0         0 $tr++;
661 0 0       0 if ($modifier =~ /s/oxms) {
662 0   0     0 while (@char and (not exists $tr{$char[0]})) {
663 0         0 shift @char;
664 0         0 $tr++;
665             }
666             }
667             }
668             else {
669 0         0 $replaced .= $char;
670             }
671             }
672             }
673             else {
674 0         0 while (defined(my $char = shift @char)) {
675 0 0       0 if (exists $tr{$char}) {
676 0         0 $replaced .= $tr{$char};
677 0         0 $tr++;
678 0 0       0 if ($modifier =~ /s/oxms) {
679 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
680 0         0 shift @char;
681 0         0 $tr++;
682             }
683             }
684             }
685             else {
686 0         0 $replaced .= $char;
687             }
688             }
689             }
690              
691 0 0       0 if ($modifier =~ /r/oxms) {
692 0         0 return $replaced;
693             }
694             else {
695 0         0 $_[0] = $replaced;
696 0 0       0 if ($bind_operator =~ / !~ /oxms) {
697 0         0 return not $tr;
698             }
699             else {
700 0         0 return $tr;
701             }
702             }
703             }
704              
705             #
706             # US-ASCII chop
707             #
708             sub Eusascii::chop(@) {
709              
710 0     0 0 0 my $chop;
711 0 0       0 if (@_ == 0) {
712 0         0 my @char = /\G (?>$q_char) /oxmsg;
713 0         0 $chop = pop @char;
714 0         0 $_ = join '', @char;
715             }
716             else {
717 0         0 for (@_) {
718 0         0 my @char = /\G (?>$q_char) /oxmsg;
719 0         0 $chop = pop @char;
720 0         0 $_ = join '', @char;
721             }
722             }
723 0         0 return $chop;
724             }
725              
726             #
727             # US-ASCII index by octet
728             #
729             sub Eusascii::index($$;$) {
730              
731 0     0 1 0 my($str,$substr,$position) = @_;
732 0   0     0 $position ||= 0;
733 0         0 my $pos = 0;
734              
735 0         0 while ($pos < CORE::length($str)) {
736 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
737 0 0       0 if ($pos >= $position) {
738 0         0 return $pos;
739             }
740             }
741 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
742 0         0 $pos += CORE::length($1);
743             }
744             else {
745 0         0 $pos += 1;
746             }
747             }
748 0         0 return -1;
749             }
750              
751             #
752             # US-ASCII reverse index
753             #
754             sub Eusascii::rindex($$;$) {
755              
756 0     0 0 0 my($str,$substr,$position) = @_;
757 0   0     0 $position ||= CORE::length($str) - 1;
758 0         0 my $pos = 0;
759 0         0 my $rindex = -1;
760              
761 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
762 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
763 0         0 $rindex = $pos;
764             }
765 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
766 0         0 $pos += CORE::length($1);
767             }
768             else {
769 0         0 $pos += 1;
770             }
771             }
772 0         0 return $rindex;
773             }
774              
775             #
776             # US-ASCII lower case first with parameter
777             #
778             sub Eusascii::lcfirst(@) {
779 0 0   0 0 0 if (@_) {
780 0         0 my $s = shift @_;
781 0 0 0     0 if (@_ and wantarray) {
782 0         0 return Eusascii::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
783             }
784             else {
785 0         0 return Eusascii::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
786             }
787             }
788             else {
789 0         0 return Eusascii::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
790             }
791             }
792              
793             #
794             # US-ASCII lower case first without parameter
795             #
796             sub Eusascii::lcfirst_() {
797 0     0 0 0 return Eusascii::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
798             }
799              
800             #
801             # US-ASCII lower case with parameter
802             #
803             sub Eusascii::lc(@) {
804 0 0   0 0 0 if (@_) {
805 0         0 my $s = shift @_;
806 0 0 0     0 if (@_ and wantarray) {
807 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
808             }
809             else {
810 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
811             }
812             }
813             else {
814 0         0 return Eusascii::lc_();
815             }
816             }
817              
818             #
819             # US-ASCII lower case without parameter
820             #
821             sub Eusascii::lc_() {
822 0     0 0 0 my $s = $_;
823 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
824             }
825              
826             #
827             # US-ASCII upper case first with parameter
828             #
829             sub Eusascii::ucfirst(@) {
830 0 0   0 0 0 if (@_) {
831 0         0 my $s = shift @_;
832 0 0 0     0 if (@_ and wantarray) {
833 0         0 return Eusascii::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
834             }
835             else {
836 0         0 return Eusascii::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
837             }
838             }
839             else {
840 0         0 return Eusascii::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
841             }
842             }
843              
844             #
845             # US-ASCII upper case first without parameter
846             #
847             sub Eusascii::ucfirst_() {
848 0     0 0 0 return Eusascii::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
849             }
850              
851             #
852             # US-ASCII upper case with parameter
853             #
854             sub Eusascii::uc(@) {
855 0 50   114 0 0 if (@_) {
856 114         165 my $s = shift @_;
857 114 50 33     142 if (@_ and wantarray) {
858 114 0       193 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
859             }
860             else {
861 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  114         358  
862             }
863             }
864             else {
865 114         397 return Eusascii::uc_();
866             }
867             }
868              
869             #
870             # US-ASCII upper case without parameter
871             #
872             sub Eusascii::uc_() {
873 0     0 0 0 my $s = $_;
874 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
875             }
876              
877             #
878             # US-ASCII fold case with parameter
879             #
880             sub Eusascii::fc(@) {
881 0 50   137 0 0 if (@_) {
882 137         189 my $s = shift @_;
883 137 50 33     155 if (@_ and wantarray) {
884 137 0       245 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
885             }
886             else {
887 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  137         367  
888             }
889             }
890             else {
891 137         835 return Eusascii::fc_();
892             }
893             }
894              
895             #
896             # US-ASCII fold case without parameter
897             #
898             sub Eusascii::fc_() {
899 0     0 0 0 my $s = $_;
900 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
901             }
902              
903             #
904             # US-ASCII regexp capture
905             #
906             {
907             sub Eusascii::capture {
908 0     0 1 0 return $_[0];
909             }
910             }
911              
912             #
913             # US-ASCII regexp ignore case modifier
914             #
915             sub Eusascii::ignorecase {
916              
917 0     0 0 0 my @string = @_;
918 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
919              
920             # ignore case of $scalar or @array
921 0         0 for my $string (@string) {
922              
923             # split regexp
924 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
925              
926             # unescape character
927 0         0 for (my $i=0; $i <= $#char; $i++) {
928 0 0       0 next if not defined $char[$i];
929              
930             # open character class [...]
931 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
932 0         0 my $left = $i;
933              
934             # [] make die "unmatched [] in regexp ...\n"
935              
936 0 0       0 if ($char[$i+1] eq ']') {
937 0         0 $i++;
938             }
939              
940 0         0 while (1) {
941 0 0       0 if (++$i > $#char) {
942 0         0 croak "Unmatched [] in regexp";
943             }
944 0 0       0 if ($char[$i] eq ']') {
945 0         0 my $right = $i;
946 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
947              
948             # escape character
949 0         0 for my $char (@charlist) {
950 0 0       0 if (0) {
951             }
952              
953 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
954 0         0 $char = '\\' . $char;
955             }
956             }
957              
958             # [...]
959 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
960              
961 0         0 $i = $left;
962 0         0 last;
963             }
964             }
965             }
966              
967             # open character class [^...]
968             elsif ($char[$i] eq '[^') {
969 0         0 my $left = $i;
970              
971             # [^] make die "unmatched [] in regexp ...\n"
972              
973 0 0       0 if ($char[$i+1] eq ']') {
974 0         0 $i++;
975             }
976              
977 0         0 while (1) {
978 0 0       0 if (++$i > $#char) {
979 0         0 croak "Unmatched [] in regexp";
980             }
981 0 0       0 if ($char[$i] eq ']') {
982 0         0 my $right = $i;
983 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
984              
985             # escape character
986 0         0 for my $char (@charlist) {
987 0 0       0 if (0) {
988             }
989              
990 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
991 0         0 $char = '\\' . $char;
992             }
993             }
994              
995             # [^...]
996 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
997              
998 0         0 $i = $left;
999 0         0 last;
1000             }
1001             }
1002             }
1003              
1004             # rewrite classic character class or escape character
1005             elsif (my $char = classic_character_class($char[$i])) {
1006 0         0 $char[$i] = $char;
1007             }
1008              
1009             # with /i modifier
1010             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1011 0         0 my $uc = Eusascii::uc($char[$i]);
1012 0         0 my $fc = Eusascii::fc($char[$i]);
1013 0 0       0 if ($uc ne $fc) {
1014 0 0       0 if (CORE::length($fc) == 1) {
1015 0         0 $char[$i] = '[' . $uc . $fc . ']';
1016             }
1017             else {
1018 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1019             }
1020             }
1021             }
1022             }
1023              
1024             # characterize
1025 0         0 for (my $i=0; $i <= $#char; $i++) {
1026 0 0       0 next if not defined $char[$i];
1027              
1028 0 0       0 if (0) {
1029             }
1030              
1031             # quote character before ? + * {
1032 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1033 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1034 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1035             }
1036             }
1037             }
1038              
1039 0         0 $string = join '', @char;
1040             }
1041              
1042             # make regexp string
1043 0         0 return @string;
1044             }
1045              
1046             #
1047             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1048             #
1049             sub Eusascii::classic_character_class {
1050 0     1827 0 0 my($char) = @_;
1051              
1052             return {
1053             '\D' => '${Eusascii::eD}',
1054             '\S' => '${Eusascii::eS}',
1055             '\W' => '${Eusascii::eW}',
1056             '\d' => '[0-9]',
1057              
1058             # Before Perl 5.6, \s only matched the five whitespace characters
1059             # tab, newline, form-feed, carriage return, and the space character
1060             # itself, which, taken together, is the character class [\t\n\f\r ].
1061              
1062             # Vertical tabs are now whitespace
1063             # \s in a regex now matches a vertical tab in all circumstances.
1064             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1065             # \t \n \v \f \r space
1066             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1067             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1068             '\s' => '\s',
1069              
1070             '\w' => '[0-9A-Z_a-z]',
1071             '\C' => '[\x00-\xFF]',
1072             '\X' => 'X',
1073              
1074             # \h \v \H \V
1075              
1076             # P.114 Character Class Shortcuts
1077             # in Chapter 7: In the World of Regular Expressions
1078             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1079              
1080             # P.357 13.2.3 Whitespace
1081             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1082             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1083             #
1084             # 0x00009 CHARACTER TABULATION h s
1085             # 0x0000a LINE FEED (LF) vs
1086             # 0x0000b LINE TABULATION v
1087             # 0x0000c FORM FEED (FF) vs
1088             # 0x0000d CARRIAGE RETURN (CR) vs
1089             # 0x00020 SPACE h s
1090              
1091             # P.196 Table 5-9. Alphanumeric regex metasymbols
1092             # in Chapter 5. Pattern Matching
1093             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1094              
1095             # (and so on)
1096              
1097             '\H' => '${Eusascii::eH}',
1098             '\V' => '${Eusascii::eV}',
1099             '\h' => '[\x09\x20]',
1100             '\v' => '[\x0A\x0B\x0C\x0D]',
1101             '\R' => '${Eusascii::eR}',
1102              
1103             # \N
1104             #
1105             # http://perldoc.perl.org/perlre.html
1106             # Character Classes and other Special Escapes
1107             # Any character but \n (experimental). Not affected by /s modifier
1108              
1109             '\N' => '${Eusascii::eN}',
1110              
1111             # \b \B
1112              
1113             # P.180 Boundaries: The \b and \B Assertions
1114             # in Chapter 5: Pattern Matching
1115             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1116              
1117             # P.219 Boundaries: The \b and \B Assertions
1118             # in Chapter 5: Pattern Matching
1119             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1120              
1121             # \b really means (?:(?<=\w)(?!\w)|(?
1122             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1123             '\b' => '${Eusascii::eb}',
1124              
1125             # \B really means (?:(?<=\w)(?=\w)|(?
1126             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1127             '\B' => '${Eusascii::eB}',
1128              
1129 1827   100     2558 }->{$char} || '';
1130             }
1131              
1132             #
1133             # prepare US-ASCII characters per length
1134             #
1135              
1136             # 1 octet characters
1137             my @chars1 = ();
1138             sub chars1 {
1139 1827 0   0 0 63252 if (@chars1) {
1140 0         0 return @chars1;
1141             }
1142 0 0       0 if (exists $range_tr{1}) {
1143 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1144 0         0 while (my @range = splice(@ranges,0,1)) {
1145 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1146 0         0 push @chars1, pack 'C', $oct0;
1147             }
1148             }
1149             }
1150 0         0 return @chars1;
1151             }
1152              
1153             # 2 octets characters
1154             my @chars2 = ();
1155             sub chars2 {
1156 0 0   0 0 0 if (@chars2) {
1157 0         0 return @chars2;
1158             }
1159 0 0       0 if (exists $range_tr{2}) {
1160 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1161 0         0 while (my @range = splice(@ranges,0,2)) {
1162 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1163 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1164 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1165             }
1166             }
1167             }
1168             }
1169 0         0 return @chars2;
1170             }
1171              
1172             # 3 octets characters
1173             my @chars3 = ();
1174             sub chars3 {
1175 0 0   0 0 0 if (@chars3) {
1176 0         0 return @chars3;
1177             }
1178 0 0       0 if (exists $range_tr{3}) {
1179 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1180 0         0 while (my @range = splice(@ranges,0,3)) {
1181 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1182 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1183 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1184 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1185             }
1186             }
1187             }
1188             }
1189             }
1190 0         0 return @chars3;
1191             }
1192              
1193             # 4 octets characters
1194             my @chars4 = ();
1195             sub chars4 {
1196 0 0   0 0 0 if (@chars4) {
1197 0         0 return @chars4;
1198             }
1199 0 0       0 if (exists $range_tr{4}) {
1200 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1201 0         0 while (my @range = splice(@ranges,0,4)) {
1202 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1203 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1204 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1205 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1206 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1207             }
1208             }
1209             }
1210             }
1211             }
1212             }
1213 0         0 return @chars4;
1214             }
1215              
1216             #
1217             # US-ASCII open character list for tr
1218             #
1219             sub _charlist_tr {
1220              
1221 0     0   0 local $_ = shift @_;
1222              
1223             # unescape character
1224 0         0 my @char = ();
1225 0         0 while (not /\G \z/oxmsgc) {
1226 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1227 0         0 push @char, '\-';
1228             }
1229             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1230 0         0 push @char, CORE::chr(oct $1);
1231             }
1232             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1233 0         0 push @char, CORE::chr(hex $1);
1234             }
1235             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1236 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1237             }
1238             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1239             push @char, {
1240             '\0' => "\0",
1241             '\n' => "\n",
1242             '\r' => "\r",
1243             '\t' => "\t",
1244             '\f' => "\f",
1245             '\b' => "\x08", # \b means backspace in character class
1246             '\a' => "\a",
1247             '\e' => "\e",
1248 0         0 }->{$1};
1249             }
1250             elsif (/\G \\ ($q_char) /oxmsgc) {
1251 0         0 push @char, $1;
1252             }
1253             elsif (/\G ($q_char) /oxmsgc) {
1254 0         0 push @char, $1;
1255             }
1256             }
1257              
1258             # join separated multiple-octet
1259 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1260              
1261             # unescape '-'
1262 0         0 my @i = ();
1263 0         0 for my $i (0 .. $#char) {
1264 0 0       0 if ($char[$i] eq '\-') {
    0          
1265 0         0 $char[$i] = '-';
1266             }
1267             elsif ($char[$i] eq '-') {
1268 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1269 0         0 push @i, $i;
1270             }
1271             }
1272             }
1273              
1274             # open character list (reverse for splice)
1275 0         0 for my $i (CORE::reverse @i) {
1276 0         0 my @range = ();
1277              
1278             # range error
1279 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1280 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1281             }
1282              
1283             # range of multiple-octet code
1284 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1285 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1286 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1287             }
1288             elsif (CORE::length($char[$i+1]) == 2) {
1289 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1290 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1291             }
1292             elsif (CORE::length($char[$i+1]) == 3) {
1293 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1294 0         0 push @range, chars2();
1295 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1296             }
1297             elsif (CORE::length($char[$i+1]) == 4) {
1298 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1299 0         0 push @range, chars2();
1300 0         0 push @range, chars3();
1301 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1302             }
1303             else {
1304 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1305             }
1306             }
1307             elsif (CORE::length($char[$i-1]) == 2) {
1308 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1309 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1310             }
1311             elsif (CORE::length($char[$i+1]) == 3) {
1312 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1313 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1314             }
1315             elsif (CORE::length($char[$i+1]) == 4) {
1316 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1317 0         0 push @range, chars3();
1318 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1319             }
1320             else {
1321 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1322             }
1323             }
1324             elsif (CORE::length($char[$i-1]) == 3) {
1325 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1326 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1327             }
1328             elsif (CORE::length($char[$i+1]) == 4) {
1329 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1330 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1331             }
1332             else {
1333 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1334             }
1335             }
1336             elsif (CORE::length($char[$i-1]) == 4) {
1337 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1338 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1339             }
1340             else {
1341 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1342             }
1343             }
1344             else {
1345 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1346             }
1347              
1348 0         0 splice @char, $i-1, 3, @range;
1349             }
1350              
1351 0         0 return @char;
1352             }
1353              
1354             #
1355             # US-ASCII open character class
1356             #
1357             sub _cc {
1358 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1359 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1360             }
1361             elsif (scalar(@_) == 1) {
1362 0         0 return sprintf('\x%02X',$_[0]);
1363             }
1364             elsif (scalar(@_) == 2) {
1365 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1366 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1367             }
1368             elsif ($_[0] == $_[1]) {
1369 0         0 return sprintf('\x%02X',$_[0]);
1370             }
1371             elsif (($_[0]+1) == $_[1]) {
1372 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1373             }
1374             else {
1375 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1376             }
1377             }
1378             else {
1379 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1380             }
1381             }
1382              
1383             #
1384             # US-ASCII octet range
1385             #
1386             sub _octets {
1387 0     182   0 my $length = shift @_;
1388              
1389 182 50       314 if ($length == 1) {
1390 182         410 my($a1) = unpack 'C', $_[0];
1391 182         478 my($z1) = unpack 'C', $_[1];
1392              
1393 182 50       324 if ($a1 > $z1) {
1394 182         372 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1395             }
1396              
1397 0 50       0 if ($a1 == $z1) {
    50          
1398 182         417 return sprintf('\x%02X',$a1);
1399             }
1400             elsif (($a1+1) == $z1) {
1401 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1402             }
1403             else {
1404 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1405             }
1406             }
1407             else {
1408 182         1198 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1409             }
1410             }
1411              
1412             #
1413             # US-ASCII range regexp
1414             #
1415             sub _range_regexp {
1416 0     182   0 my($length,$first,$last) = @_;
1417              
1418 182         433 my @range_regexp = ();
1419 182 50       252 if (not exists $range_tr{$length}) {
1420 182         438 return @range_regexp;
1421             }
1422              
1423 0         0 my @ranges = @{ $range_tr{$length} };
  182         270  
1424 182         386 while (my @range = splice(@ranges,0,$length)) {
1425 182         564 my $min = '';
1426 182         283 my $max = '';
1427 182         250 for (my $i=0; $i < $length; $i++) {
1428 182         492 $min .= pack 'C', $range[$i][0];
1429 182         691 $max .= pack 'C', $range[$i][-1];
1430             }
1431              
1432             # min___max
1433             # FIRST_____________LAST
1434             # (nothing)
1435              
1436 182 50 33     455 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1437             }
1438              
1439             # **********
1440             # min_________max
1441             # FIRST_____________LAST
1442             # **********
1443              
1444             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1445 182         1731 push @range_regexp, _octets($length,$first,$max,$min,$max);
1446             }
1447              
1448             # **********************
1449             # min________________max
1450             # FIRST_____________LAST
1451             # **********************
1452              
1453             elsif (($min eq $first) and ($max eq $last)) {
1454 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1455             }
1456              
1457             # *********
1458             # min___max
1459             # FIRST_____________LAST
1460             # *********
1461              
1462             elsif (($first le $min) and ($max le $last)) {
1463 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1464             }
1465              
1466             # **********************
1467             # min__________________________max
1468             # FIRST_____________LAST
1469             # **********************
1470              
1471             elsif (($min le $first) and ($last le $max)) {
1472 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1473             }
1474              
1475             # *********
1476             # min________max
1477             # FIRST_____________LAST
1478             # *********
1479              
1480             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1481 182         430 push @range_regexp, _octets($length,$min,$last,$min,$max);
1482             }
1483              
1484             # min___max
1485             # FIRST_____________LAST
1486             # (nothing)
1487              
1488             elsif ($last lt $min) {
1489             }
1490              
1491             else {
1492 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1493             }
1494             }
1495              
1496 0         0 return @range_regexp;
1497             }
1498              
1499             #
1500             # US-ASCII open character list for qr and not qr
1501             #
1502             sub _charlist {
1503              
1504 182     346   462 my $modifier = pop @_;
1505 346         585 my @char = @_;
1506              
1507 346 100       792 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1508              
1509             # unescape character
1510 346         743 for (my $i=0; $i <= $#char; $i++) {
1511              
1512             # escape - to ...
1513 346 100 100     1103 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1514 1101 100 100     7729 if ((0 < $i) and ($i < $#char)) {
1515 206         755 $char[$i] = '...';
1516             }
1517             }
1518              
1519             # octal escape sequence
1520             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1521 182         397 $char[$i] = octchr($1);
1522             }
1523              
1524             # hexadecimal escape sequence
1525             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1526 0         0 $char[$i] = hexchr($1);
1527             }
1528              
1529             # \b{...} --> b\{...}
1530             # \B{...} --> B\{...}
1531             # \N{CHARNAME} --> N\{CHARNAME}
1532             # \p{PROPERTY} --> p\{PROPERTY}
1533             # \P{PROPERTY} --> P\{PROPERTY}
1534             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1535 0         0 $char[$i] = $1 . '\\' . $2;
1536             }
1537              
1538             # \p, \P, \X --> p, P, X
1539             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1540 0         0 $char[$i] = $1;
1541             }
1542              
1543             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1544 0         0 $char[$i] = CORE::chr oct $1;
1545             }
1546             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1547 0         0 $char[$i] = CORE::chr hex $1;
1548             }
1549             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1550 22         93 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1551             }
1552             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1553             $char[$i] = {
1554             '\0' => "\0",
1555             '\n' => "\n",
1556             '\r' => "\r",
1557             '\t' => "\t",
1558             '\f' => "\f",
1559             '\b' => "\x08", # \b means backspace in character class
1560             '\a' => "\a",
1561             '\e' => "\e",
1562             '\d' => '[0-9]',
1563              
1564             # Vertical tabs are now whitespace
1565             # \s in a regex now matches a vertical tab in all circumstances.
1566             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1567             # \t \n \v \f \r space
1568             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1569             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1570             '\s' => '\s',
1571              
1572             '\w' => '[0-9A-Z_a-z]',
1573             '\D' => '${Eusascii::eD}',
1574             '\S' => '${Eusascii::eS}',
1575             '\W' => '${Eusascii::eW}',
1576              
1577             '\H' => '${Eusascii::eH}',
1578             '\V' => '${Eusascii::eV}',
1579             '\h' => '[\x09\x20]',
1580             '\v' => '[\x0A\x0B\x0C\x0D]',
1581             '\R' => '${Eusascii::eR}',
1582              
1583 0         0 }->{$1};
1584             }
1585              
1586             # POSIX-style character classes
1587             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1588             $char[$i] = {
1589              
1590             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1591             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1592             '[:^lower:]' => '${Eusascii::not_lower_i}',
1593             '[:^upper:]' => '${Eusascii::not_upper_i}',
1594              
1595 25         399 }->{$1};
1596             }
1597             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1598             $char[$i] = {
1599              
1600             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1601             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1602             '[:ascii:]' => '[\x00-\x7F]',
1603             '[:blank:]' => '[\x09\x20]',
1604             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1605             '[:digit:]' => '[\x30-\x39]',
1606             '[:graph:]' => '[\x21-\x7F]',
1607             '[:lower:]' => '[\x61-\x7A]',
1608             '[:print:]' => '[\x20-\x7F]',
1609             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1610              
1611             # P.174 POSIX-Style Character Classes
1612             # in Chapter 5: Pattern Matching
1613             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1614              
1615             # P.311 11.2.4 Character Classes and other Special Escapes
1616             # in Chapter 11: perlre: Perl regular expressions
1617             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1618              
1619             # P.210 POSIX-Style Character Classes
1620             # in Chapter 5: Pattern Matching
1621             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1622              
1623             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1624              
1625             '[:upper:]' => '[\x41-\x5A]',
1626             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1627             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1628             '[:^alnum:]' => '${Eusascii::not_alnum}',
1629             '[:^alpha:]' => '${Eusascii::not_alpha}',
1630             '[:^ascii:]' => '${Eusascii::not_ascii}',
1631             '[:^blank:]' => '${Eusascii::not_blank}',
1632             '[:^cntrl:]' => '${Eusascii::not_cntrl}',
1633             '[:^digit:]' => '${Eusascii::not_digit}',
1634             '[:^graph:]' => '${Eusascii::not_graph}',
1635             '[:^lower:]' => '${Eusascii::not_lower}',
1636             '[:^print:]' => '${Eusascii::not_print}',
1637             '[:^punct:]' => '${Eusascii::not_punct}',
1638             '[:^space:]' => '${Eusascii::not_space}',
1639             '[:^upper:]' => '${Eusascii::not_upper}',
1640             '[:^word:]' => '${Eusascii::not_word}',
1641             '[:^xdigit:]' => '${Eusascii::not_xdigit}',
1642              
1643 8         63 }->{$1};
1644             }
1645             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1646 70         1183 $char[$i] = $1;
1647             }
1648             }
1649              
1650             # open character list
1651 7         29 my @singleoctet = ();
1652 346         597 my @multipleoctet = ();
1653 346         453 for (my $i=0; $i <= $#char; ) {
1654              
1655             # escaped -
1656 346 100 100     768 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1657 919         3747 $i += 1;
1658 182         268 next;
1659             }
1660              
1661             # make range regexp
1662             elsif ($char[$i] eq '...') {
1663              
1664             # range error
1665 182 50       350 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1666 182         692 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1667             }
1668             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1669 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1670 182         456 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1671             }
1672             }
1673              
1674             # make range regexp per length
1675 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1676 182         531 my @regexp = ();
1677              
1678             # is first and last
1679 182 50 33     280 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1680 182         684 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1681             }
1682              
1683             # is first
1684             elsif ($length == CORE::length($char[$i-1])) {
1685 182         507 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1686             }
1687              
1688             # is inside in first and last
1689             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1690 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1691             }
1692              
1693             # is last
1694             elsif ($length == CORE::length($char[$i+1])) {
1695 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1696             }
1697              
1698             else {
1699 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1700             }
1701              
1702 0 50       0 if ($length == 1) {
1703 182         360 push @singleoctet, @regexp;
1704             }
1705             else {
1706 182         411 push @multipleoctet, @regexp;
1707             }
1708             }
1709              
1710 0         0 $i += 2;
1711             }
1712              
1713             # with /i modifier
1714             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1715 182 50       411 if ($modifier =~ /i/oxms) {
1716 469         749 my $uc = Eusascii::uc($char[$i]);
1717 0         0 my $fc = Eusascii::fc($char[$i]);
1718 0 0       0 if ($uc ne $fc) {
1719 0 0       0 if (CORE::length($fc) == 1) {
1720 0         0 push @singleoctet, $uc, $fc;
1721             }
1722             else {
1723 0         0 push @singleoctet, $uc;
1724 0         0 push @multipleoctet, $fc;
1725             }
1726             }
1727             else {
1728 0         0 push @singleoctet, $char[$i];
1729             }
1730             }
1731             else {
1732 0         0 push @singleoctet, $char[$i];
1733             }
1734 469         765 $i += 1;
1735             }
1736              
1737             # single character of single octet code
1738             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1739 469         800 push @singleoctet, "\t", "\x20";
1740 0         0 $i += 1;
1741             }
1742             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1743 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1744 0         0 $i += 1;
1745             }
1746             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1747 0         0 push @singleoctet, $char[$i];
1748 2         5 $i += 1;
1749             }
1750              
1751             # single character of multiple-octet code
1752             else {
1753 2         5 push @multipleoctet, $char[$i];
1754 84         188 $i += 1;
1755             }
1756             }
1757              
1758             # quote metachar
1759 84         164 for (@singleoctet) {
1760 346 50       686 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1761 653         2918 $_ = '-';
1762             }
1763             elsif (/\A \n \z/oxms) {
1764 0         0 $_ = '\n';
1765             }
1766             elsif (/\A \r \z/oxms) {
1767 8         21 $_ = '\r';
1768             }
1769             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1770 8         24 $_ = sprintf('\x%02X', CORE::ord $1);
1771             }
1772             elsif (/\A [\x00-\xFF] \z/oxms) {
1773 24         96 $_ = quotemeta $_;
1774             }
1775             }
1776              
1777             # return character list
1778 429         725 return \@singleoctet, \@multipleoctet;
1779             }
1780              
1781             #
1782             # US-ASCII octal escape sequence
1783             #
1784             sub octchr {
1785 346     5 0 1376 my($octdigit) = @_;
1786              
1787 5         11 my @binary = ();
1788 5         9 for my $octal (split(//,$octdigit)) {
1789             push @binary, {
1790             '0' => '000',
1791             '1' => '001',
1792             '2' => '010',
1793             '3' => '011',
1794             '4' => '100',
1795             '5' => '101',
1796             '6' => '110',
1797             '7' => '111',
1798 5         19 }->{$octal};
1799             }
1800 50         166 my $binary = join '', @binary;
1801              
1802             my $octchr = {
1803             # 1234567
1804             1 => pack('B*', "0000000$binary"),
1805             2 => pack('B*', "000000$binary"),
1806             3 => pack('B*', "00000$binary"),
1807             4 => pack('B*', "0000$binary"),
1808             5 => pack('B*', "000$binary"),
1809             6 => pack('B*', "00$binary"),
1810             7 => pack('B*', "0$binary"),
1811             0 => pack('B*', "$binary"),
1812              
1813 5         13 }->{CORE::length($binary) % 8};
1814              
1815 5         53 return $octchr;
1816             }
1817              
1818             #
1819             # US-ASCII hexadecimal escape sequence
1820             #
1821             sub hexchr {
1822 5     5 0 17 my($hexdigit) = @_;
1823              
1824             my $hexchr = {
1825             1 => pack('H*', "0$hexdigit"),
1826             0 => pack('H*', "$hexdigit"),
1827              
1828 5         11 }->{CORE::length($_[0]) % 2};
1829              
1830 5         36 return $hexchr;
1831             }
1832              
1833             #
1834             # US-ASCII open character list for qr
1835             #
1836             sub charlist_qr {
1837              
1838 5     302 0 15 my $modifier = pop @_;
1839 302         591 my @char = @_;
1840              
1841 302         743 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1842 302         863 my @singleoctet = @$singleoctet;
1843 302         634 my @multipleoctet = @$multipleoctet;
1844              
1845             # return character list
1846 302 100       465 if (scalar(@singleoctet) >= 1) {
1847              
1848             # with /i modifier
1849 302 100       702 if ($modifier =~ m/i/oxms) {
1850 224         502 my %singleoctet_ignorecase = ();
1851 10         13 for (@singleoctet) {
1852 10   66     14 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1853 10         43 for my $ord (hex($1) .. hex($2)) {
1854 10         32 my $char = CORE::chr($ord);
1855 30         43 my $uc = Eusascii::uc($char);
1856 30         47 my $fc = Eusascii::fc($char);
1857 30 50       47 if ($uc eq $fc) {
1858 30         53 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1859             }
1860             else {
1861 0 50       0 if (CORE::length($fc) == 1) {
1862 30         36 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1863 30         65 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1864             }
1865             else {
1866 30         98 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1867 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1868             }
1869             }
1870             }
1871             }
1872 0 50       0 if ($_ ne '') {
1873 10         21 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1874             }
1875             }
1876 0         0 my $i = 0;
1877 10         35 my @singleoctet_ignorecase = ();
1878 10         13 for my $ord (0 .. 255) {
1879 10 100       17 if (exists $singleoctet_ignorecase{$ord}) {
1880 2560         2911 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         53  
1881             }
1882             else {
1883 60         105 $i++;
1884             }
1885             }
1886 2500         2510 @singleoctet = ();
1887 10         14 for my $range (@singleoctet_ignorecase) {
1888 10 100       33 if (ref $range) {
1889 960 50       1436 if (scalar(@{$range}) == 1) {
  20 50       20  
1890 20         28 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1891             }
1892 0         0 elsif (scalar(@{$range}) == 2) {
1893 20         28 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1894             }
1895             else {
1896 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         21  
  20         25  
1897             }
1898             }
1899             }
1900             }
1901              
1902 20         74 my $not_anchor = '';
1903              
1904 224         349 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
1905             }
1906 224 100       651 if (scalar(@multipleoctet) >= 2) {
1907 302         630 return '(?:' . join('|', @multipleoctet) . ')';
1908             }
1909             else {
1910 6         29 return $multipleoctet[0];
1911             }
1912             }
1913              
1914             #
1915             # US-ASCII open character list for not qr
1916             #
1917             sub charlist_not_qr {
1918              
1919 296     44 0 1281 my $modifier = pop @_;
1920 44         88 my @char = @_;
1921              
1922 44         153 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1923 44         154 my @singleoctet = @$singleoctet;
1924 44         102 my @multipleoctet = @$multipleoctet;
1925              
1926             # with /i modifier
1927 44 100       75 if ($modifier =~ m/i/oxms) {
1928 44         105 my %singleoctet_ignorecase = ();
1929 10         12 for (@singleoctet) {
1930 10   66     13 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1931 10         44 for my $ord (hex($1) .. hex($2)) {
1932 10         30 my $char = CORE::chr($ord);
1933 30         42 my $uc = Eusascii::uc($char);
1934 30         42 my $fc = Eusascii::fc($char);
1935 30 50       47 if ($uc eq $fc) {
1936 30         47 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1937             }
1938             else {
1939 0 50       0 if (CORE::length($fc) == 1) {
1940 30         42 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1941 30         60 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1942             }
1943             else {
1944 30         97 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1945 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1946             }
1947             }
1948             }
1949             }
1950 0 50       0 if ($_ ne '') {
1951 10         22 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1952             }
1953             }
1954 0         0 my $i = 0;
1955 10         11 my @singleoctet_ignorecase = ();
1956 10         15 for my $ord (0 .. 255) {
1957 10 100       17 if (exists $singleoctet_ignorecase{$ord}) {
1958 2560         2893 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         59  
1959             }
1960             else {
1961 60         95 $i++;
1962             }
1963             }
1964 2500         2518 @singleoctet = ();
1965 10         18 for my $range (@singleoctet_ignorecase) {
1966 10 100       24 if (ref $range) {
1967 960 50       1506 if (scalar(@{$range}) == 1) {
  20 50       21  
1968 20         32 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1969             }
1970 0         0 elsif (scalar(@{$range}) == 2) {
1971 20         34 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1972             }
1973             else {
1974 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         23  
  20         22  
1975             }
1976             }
1977             }
1978             }
1979              
1980             # return character list
1981 20 50       77 if (scalar(@multipleoctet) >= 1) {
1982 44 0       111 if (scalar(@singleoctet) >= 1) {
1983              
1984             # any character other than multiple-octet and single octet character class
1985 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
1986             }
1987             else {
1988              
1989             # any character other than multiple-octet character class
1990 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
1991             }
1992             }
1993             else {
1994 0 50       0 if (scalar(@singleoctet) >= 1) {
1995              
1996             # any character other than single octet character class
1997 44         99 return '(?:[^' . join('', @singleoctet) . '])';
1998             }
1999             else {
2000              
2001             # any character
2002 44         243 return "(?:$your_char)";
2003             }
2004             }
2005             }
2006              
2007             #
2008             # open file in read mode
2009             #
2010             sub _open_r {
2011 0     408   0 my(undef,$file) = @_;
2012 204     204   1965 use Fcntl qw(O_RDONLY);
  204         448  
  204         25308  
2013 408         7224 return CORE::sysopen($_[0], $file, &O_RDONLY);
2014             }
2015              
2016             #
2017             # open file in append mode
2018             #
2019             sub _open_a {
2020 408     204   24330 my(undef,$file) = @_;
2021 204     204   1370 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         458  
  204         514952  
2022 204         3652 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2023             }
2024              
2025             #
2026             # safe system
2027             #
2028             sub _systemx {
2029              
2030             # P.707 29.2.33. exec
2031             # in Chapter 29: Functions
2032             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2033             #
2034             # Be aware that in older releases of Perl, exec (and system) did not flush
2035             # your output buffer, so you needed to enable command buffering by setting $|
2036             # on one or more filehandles to avoid lost output in the case of exec, or
2037             # misordererd output in the case of system. This situation was largely remedied
2038             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2039              
2040             # P.855 exec
2041             # in Chapter 27: Functions
2042             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2043             #
2044             # In very old release of Perl (before v5.6), exec (and system) did not flush
2045             # your output buffer, so you needed to enable command buffering by setting $|
2046             # on one or more filehandles to avoid lost output with exec or misordered
2047             # output with system.
2048              
2049 204     204   27566 $| = 1;
2050              
2051             # P.565 23.1.2. Cleaning Up Your Environment
2052             # in Chapter 23: Security
2053             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2054              
2055             # P.656 Cleaning Up Your Environment
2056             # in Chapter 20: Security
2057             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2058              
2059             # local $ENV{'PATH'} = '.';
2060 204         706 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2061              
2062             # P.707 29.2.33. exec
2063             # in Chapter 29: Functions
2064             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2065             #
2066             # As we mentioned earlier, exec treats a discrete list of arguments as an
2067             # indication that it should bypass shell processing. However, there is one
2068             # place where you might still get tripped up. The exec call (and system, too)
2069             # will not distinguish between a single scalar argument and an array containing
2070             # only one element.
2071             #
2072             # @args = ("echo surprise"); # just one element in list
2073             # exec @args # still subject to shell escapes
2074             # or die "exec: $!"; # because @args == 1
2075             #
2076             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2077             # first argument as the pathname, which forces the rest of the arguments to be
2078             # interpreted as a list, even if there is only one of them:
2079             #
2080             # exec { $args[0] } @args # safe even with one-argument list
2081             # or die "can't exec @args: $!";
2082              
2083             # P.855 exec
2084             # in Chapter 27: Functions
2085             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2086             #
2087             # As we mentioned earlier, exec treats a discrete list of arguments as a
2088             # directive to bypass shell processing. However, there is one place where
2089             # you might still get tripped up. The exec call (and system, too) cannot
2090             # distinguish between a single scalar argument and an array containing
2091             # only one element.
2092             #
2093             # @args = ("echo surprise"); # just one element in list
2094             # exec @args # still subject to shell escapes
2095             # || die "exec: $!"; # because @args == 1
2096             #
2097             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2098             # argument as the pathname, which forces the rest of the arguments to be
2099             # interpreted as a list, even if there is only one of them:
2100             #
2101             # exec { $args[0] } @args # safe even with one-argument list
2102             # || die "can't exec @args: $!";
2103              
2104 204         1618 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         422  
2105             }
2106              
2107             #
2108             # US-ASCII order to character (with parameter)
2109             #
2110             sub Eusascii::chr(;$) {
2111              
2112 204 0   0 0 13875296 my $c = @_ ? $_[0] : $_;
2113              
2114 0 0       0 if ($c == 0x00) {
2115 0         0 return "\x00";
2116             }
2117             else {
2118 0         0 my @chr = ();
2119 0         0 while ($c > 0) {
2120 0         0 unshift @chr, ($c % 0x100);
2121 0         0 $c = int($c / 0x100);
2122             }
2123 0         0 return pack 'C*', @chr;
2124             }
2125             }
2126              
2127             #
2128             # US-ASCII order to character (without parameter)
2129             #
2130             sub Eusascii::chr_() {
2131              
2132 0     0 0 0 my $c = $_;
2133              
2134 0 0       0 if ($c == 0x00) {
2135 0         0 return "\x00";
2136             }
2137             else {
2138 0         0 my @chr = ();
2139 0         0 while ($c > 0) {
2140 0         0 unshift @chr, ($c % 0x100);
2141 0         0 $c = int($c / 0x100);
2142             }
2143 0         0 return pack 'C*', @chr;
2144             }
2145             }
2146              
2147             #
2148             # US-ASCII path globbing (with parameter)
2149             #
2150             sub Eusascii::glob($) {
2151              
2152 0 0   0 0 0 if (wantarray) {
2153 0         0 my @glob = _DOS_like_glob(@_);
2154 0         0 for my $glob (@glob) {
2155 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2156             }
2157 0         0 return @glob;
2158             }
2159             else {
2160 0         0 my $glob = _DOS_like_glob(@_);
2161 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2162 0         0 return $glob;
2163             }
2164             }
2165              
2166             #
2167             # US-ASCII path globbing (without parameter)
2168             #
2169             sub Eusascii::glob_() {
2170              
2171 0 0   0 0 0 if (wantarray) {
2172 0         0 my @glob = _DOS_like_glob();
2173 0         0 for my $glob (@glob) {
2174 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2175             }
2176 0         0 return @glob;
2177             }
2178             else {
2179 0         0 my $glob = _DOS_like_glob();
2180 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2181 0         0 return $glob;
2182             }
2183             }
2184              
2185             #
2186             # US-ASCII path globbing via File::DosGlob 1.10
2187             #
2188             # Often I confuse "_dosglob" and "_doglob".
2189             # So, I renamed "_dosglob" to "_DOS_like_glob".
2190             #
2191             my %iter;
2192             my %entries;
2193             sub _DOS_like_glob {
2194              
2195             # context (keyed by second cxix argument provided by core)
2196 0     0   0 my($expr,$cxix) = @_;
2197              
2198             # glob without args defaults to $_
2199 0 0       0 $expr = $_ if not defined $expr;
2200              
2201             # represents the current user's home directory
2202             #
2203             # 7.3. Expanding Tildes in Filenames
2204             # in Chapter 7. File Access
2205             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2206             #
2207             # and File::HomeDir, File::HomeDir::Windows module
2208              
2209             # DOS-like system
2210 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2211 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2212             { my_home_MSWin32() }oxmse;
2213             }
2214              
2215             # UNIX-like system
2216 0 0 0     0 else {
  0         0  
2217             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2218             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2219             }
2220 0 0       0  
2221 0 0       0 # assume global context if not provided one
2222             $cxix = '_G_' if not defined $cxix;
2223             $iter{$cxix} = 0 if not exists $iter{$cxix};
2224 0 0       0  
2225 0         0 # if we're just beginning, do it all first
2226             if ($iter{$cxix} == 0) {
2227             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2228             }
2229 0 0       0  
2230 0         0 # chuck it all out, quick or slow
2231 0         0 if (wantarray) {
  0         0  
2232             delete $iter{$cxix};
2233             return @{delete $entries{$cxix}};
2234 0 0       0 }
  0         0  
2235 0         0 else {
  0         0  
2236             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2237             return shift @{$entries{$cxix}};
2238             }
2239 0         0 else {
2240 0         0 # return undef for EOL
2241 0         0 delete $iter{$cxix};
2242             delete $entries{$cxix};
2243             return undef;
2244             }
2245             }
2246             }
2247              
2248             #
2249             # US-ASCII path globbing subroutine
2250             #
2251 0     0   0 sub _do_glob {
2252 0         0  
2253 0         0 my($cond,@expr) = @_;
2254             my @glob = ();
2255             my $fix_drive_relative_paths = 0;
2256 0         0  
2257 0 0       0 OUTER:
2258 0 0       0 for my $expr (@expr) {
2259             next OUTER if not defined $expr;
2260 0         0 next OUTER if $expr eq '';
2261 0         0  
2262 0         0 my @matched = ();
2263 0         0 my @globdir = ();
2264 0         0 my $head = '.';
2265             my $pathsep = '/';
2266             my $tail;
2267 0 0       0  
2268 0         0 # if argument is within quotes strip em and do no globbing
2269 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2270 0 0       0 $expr = $1;
2271 0         0 if ($cond eq 'd') {
2272             if (-d $expr) {
2273             push @glob, $expr;
2274             }
2275 0 0       0 }
2276 0         0 else {
2277             if (-e $expr) {
2278             push @glob, $expr;
2279 0         0 }
2280             }
2281             next OUTER;
2282             }
2283              
2284 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2285 0 0       0 # to h:./*.pm to expand correctly
2286 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2287             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2288             $fix_drive_relative_paths = 1;
2289             }
2290 0 0       0 }
2291 0 0       0  
2292 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2293 0         0 if ($tail eq '') {
2294             push @glob, $expr;
2295 0 0       0 next OUTER;
2296 0 0       0 }
2297 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2298 0         0 if (@globdir = _do_glob('d', $head)) {
2299             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2300             next OUTER;
2301 0 0 0     0 }
2302 0         0 }
2303             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2304 0         0 $head .= $pathsep;
2305             }
2306             $expr = $tail;
2307             }
2308 0 0       0  
2309 0 0       0 # If file component has no wildcards, we can avoid opendir
2310 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2311             if ($head eq '.') {
2312 0 0 0     0 $head = '';
2313 0         0 }
2314             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2315 0         0 $head .= $pathsep;
2316 0 0       0 }
2317 0 0       0 $head .= $expr;
2318 0         0 if ($cond eq 'd') {
2319             if (-d $head) {
2320             push @glob, $head;
2321             }
2322 0 0       0 }
2323 0         0 else {
2324             if (-e $head) {
2325             push @glob, $head;
2326 0         0 }
2327             }
2328 0 0       0 next OUTER;
2329 0         0 }
2330 0         0 opendir(*DIR, $head) or next OUTER;
2331             my @leaf = readdir DIR;
2332 0 0       0 closedir DIR;
2333 0         0  
2334             if ($head eq '.') {
2335 0 0 0     0 $head = '';
2336 0         0 }
2337             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2338             $head .= $pathsep;
2339 0         0 }
2340 0         0  
2341 0         0 my $pattern = '';
2342             while ($expr =~ / \G ($q_char) /oxgc) {
2343             my $char = $1;
2344              
2345             # 6.9. Matching Shell Globs as Regular Expressions
2346             # in Chapter 6. Pattern Matching
2347             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2348 0 0       0 # (and so on)
    0          
    0          
2349 0         0  
2350             if ($char eq '*') {
2351             $pattern .= "(?:$your_char)*",
2352 0         0 }
2353             elsif ($char eq '?') {
2354             $pattern .= "(?:$your_char)?", # DOS style
2355             # $pattern .= "(?:$your_char)", # UNIX style
2356 0         0 }
2357             elsif ((my $fc = Eusascii::fc($char)) ne $char) {
2358             $pattern .= $fc;
2359 0         0 }
2360             else {
2361             $pattern .= quotemeta $char;
2362 0     0   0 }
  0         0  
2363             }
2364             my $matchsub = sub { Eusascii::fc($_[0]) =~ /\A $pattern \z/xms };
2365              
2366             # if ($@) {
2367             # print STDERR "$0: $@\n";
2368             # next OUTER;
2369             # }
2370 0         0  
2371 0 0 0     0 INNER:
2372 0         0 for my $leaf (@leaf) {
2373             if ($leaf eq '.' or $leaf eq '..') {
2374 0 0 0     0 next INNER;
2375 0         0 }
2376             if ($cond eq 'd' and not -d "$head$leaf") {
2377             next INNER;
2378 0 0       0 }
2379 0         0  
2380 0         0 if (&$matchsub($leaf)) {
2381             push @matched, "$head$leaf";
2382             next INNER;
2383             }
2384              
2385             # [DOS compatibility special case]
2386 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2387              
2388             if (Eusascii::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2389             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2390 0 0       0 Eusascii::index($pattern,'\\.') != -1 # pattern has a dot.
2391 0         0 ) {
2392 0         0 if (&$matchsub("$leaf.")) {
2393             push @matched, "$head$leaf";
2394             next INNER;
2395             }
2396 0 0       0 }
2397 0         0 }
2398             if (@matched) {
2399             push @glob, @matched;
2400 0 0       0 }
2401 0         0 }
2402 0         0 if ($fix_drive_relative_paths) {
2403             for my $glob (@glob) {
2404             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2405 0         0 }
2406             }
2407             return @glob;
2408             }
2409              
2410             #
2411             # US-ASCII parse line
2412             #
2413 0     0   0 sub _parse_line {
2414              
2415 0         0 my($line) = @_;
2416 0         0  
2417 0         0 $line .= ' ';
2418             my @piece = ();
2419             while ($line =~ /
2420             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2421             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2422 0 0       0 /oxmsg
2423             ) {
2424 0         0 push @piece, defined($1) ? $1 : $2;
2425             }
2426             return @piece;
2427             }
2428              
2429             #
2430             # US-ASCII parse path
2431             #
2432 0     0   0 sub _parse_path {
2433              
2434 0         0 my($path,$pathsep) = @_;
2435 0         0  
2436 0         0 $path .= '/';
2437             my @subpath = ();
2438             while ($path =~ /
2439             ((?: [^\/\\] )+?) [\/\\]
2440 0         0 /oxmsg
2441             ) {
2442             push @subpath, $1;
2443 0         0 }
2444 0         0  
2445 0         0 my $tail = pop @subpath;
2446             my $head = join $pathsep, @subpath;
2447             return $head, $tail;
2448             }
2449              
2450             #
2451             # via File::HomeDir::Windows 1.00
2452             #
2453             sub my_home_MSWin32 {
2454              
2455             # A lot of unix people and unix-derived tools rely on
2456 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2457 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2458             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2459             return $ENV{'HOME'};
2460             }
2461              
2462 0         0 # Do we have a user profile?
2463             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2464             return $ENV{'USERPROFILE'};
2465             }
2466              
2467 0         0 # Some Windows use something like $ENV{'HOME'}
2468             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2469             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2470 0         0 }
2471              
2472             return undef;
2473             }
2474              
2475             #
2476             # via File::HomeDir::Unix 1.00
2477 0     0 0 0 #
2478             sub my_home {
2479 0 0 0     0 my $home;
    0 0        
2480 0         0  
2481             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2482             $home = $ENV{'HOME'};
2483             }
2484              
2485             # This is from the original code, but I'm guessing
2486 0         0 # it means "login directory" and exists on some Unixes.
2487             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2488             $home = $ENV{'LOGDIR'};
2489             }
2490              
2491             ### More-desperate methods
2492              
2493 0         0 # Light desperation on any (Unixish) platform
2494             else {
2495             $home = CORE::eval q{ (getpwuid($<))[7] };
2496             }
2497              
2498 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2499 0         0 # For example, "nobody"-like users might use /nonexistant
2500             if (defined $home and ! -d($home)) {
2501 0         0 $home = undef;
2502             }
2503             return $home;
2504             }
2505              
2506             #
2507             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2508 0     0 0 0 #
2509             sub Eusascii::PREMATCH {
2510             return $`;
2511             }
2512              
2513             #
2514             # ${^MATCH}, $MATCH, $& the string that matched
2515 0     0 0 0 #
2516             sub Eusascii::MATCH {
2517             return $&;
2518             }
2519              
2520             #
2521             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2522 0     0 0 0 #
2523             sub Eusascii::POSTMATCH {
2524             return $';
2525             }
2526              
2527             #
2528             # US-ASCII character to order (with parameter)
2529             #
2530 0 0   0 1 0 sub USASCII::ord(;$) {
2531              
2532 0 0       0 local $_ = shift if @_;
2533 0         0  
2534 0         0 if (/\A ($q_char) /oxms) {
2535 0         0 my @ord = unpack 'C*', $1;
2536 0         0 my $ord = 0;
2537             while (my $o = shift @ord) {
2538 0         0 $ord = $ord * 0x100 + $o;
2539             }
2540             return $ord;
2541 0         0 }
2542             else {
2543             return CORE::ord $_;
2544             }
2545             }
2546              
2547             #
2548             # US-ASCII character to order (without parameter)
2549             #
2550 0 0   0 0 0 sub USASCII::ord_() {
2551 0         0  
2552 0         0 if (/\A ($q_char) /oxms) {
2553 0         0 my @ord = unpack 'C*', $1;
2554 0         0 my $ord = 0;
2555             while (my $o = shift @ord) {
2556 0         0 $ord = $ord * 0x100 + $o;
2557             }
2558             return $ord;
2559 0         0 }
2560             else {
2561             return CORE::ord $_;
2562             }
2563             }
2564              
2565             #
2566             # US-ASCII reverse
2567             #
2568 0 0   0 0 0 sub USASCII::reverse(@) {
2569 0         0  
2570             if (wantarray) {
2571             return CORE::reverse @_;
2572             }
2573             else {
2574              
2575             # One of us once cornered Larry in an elevator and asked him what
2576             # problem he was solving with this, but he looked as far off into
2577             # the distance as he could in an elevator and said, "It seemed like
2578 0         0 # a good idea at the time."
2579              
2580             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2581             }
2582             }
2583              
2584             #
2585             # US-ASCII getc (with parameter, without parameter)
2586             #
2587 0     0 0 0 sub USASCII::getc(;*@) {
2588 0 0       0  
2589 0 0 0     0 my($package) = caller;
2590             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2591 0         0 croak 'Too many arguments for USASCII::getc' if @_ and not wantarray;
  0         0  
2592 0         0  
2593 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2594 0         0 my $getc = '';
2595 0 0       0 for my $length ($length[0] .. $length[-1]) {
2596 0 0       0 $getc .= CORE::getc($fh);
2597 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2598             if ($getc =~ /\A ${Eusascii::dot_s} \z/oxms) {
2599             return wantarray ? ($getc,@_) : $getc;
2600             }
2601 0 0       0 }
2602             }
2603             return wantarray ? ($getc,@_) : $getc;
2604             }
2605              
2606             #
2607             # US-ASCII length by character
2608             #
2609 0 0   0 1 0 sub USASCII::length(;$) {
2610              
2611 0         0 local $_ = shift if @_;
2612 0         0  
2613             local @_ = /\G ($q_char) /oxmsg;
2614             return scalar @_;
2615             }
2616              
2617             #
2618             # US-ASCII substr by character
2619             #
2620             BEGIN {
2621              
2622             # P.232 The lvalue Attribute
2623             # in Chapter 6: Subroutines
2624             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2625              
2626             # P.336 The lvalue Attribute
2627             # in Chapter 7: Subroutines
2628             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2629              
2630             # P.144 8.4 Lvalue subroutines
2631             # in Chapter 8: perlsub: Perl subroutines
2632 204 50 0 204 1 107860 # 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  
2633              
2634             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2635             # vv----------------------*******
2636             sub USASCII::substr($$;$$) %s {
2637              
2638             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2639              
2640             # If the substring is beyond either end of the string, substr() returns the undefined
2641             # value and produces a warning. When used as an lvalue, specifying a substring that
2642             # is entirely outside the string raises an exception.
2643             # http://perldoc.perl.org/functions/substr.html
2644              
2645             # A return with no argument returns the scalar value undef in scalar context,
2646             # an empty list () in list context, and (naturally) nothing at all in void
2647             # context.
2648              
2649             my $offset = $_[1];
2650             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2651             return;
2652             }
2653              
2654             # substr($string,$offset,$length,$replacement)
2655             if (@_ == 4) {
2656             my(undef,undef,$length,$replacement) = @_;
2657             my $substr = join '', splice(@char, $offset, $length, $replacement);
2658             $_[0] = join '', @char;
2659              
2660             # return $substr; this doesn't work, don't say "return"
2661             $substr;
2662             }
2663              
2664             # substr($string,$offset,$length)
2665             elsif (@_ == 3) {
2666             my(undef,undef,$length) = @_;
2667             my $octet_offset = 0;
2668             my $octet_length = 0;
2669             if ($offset == 0) {
2670             $octet_offset = 0;
2671             }
2672             elsif ($offset > 0) {
2673             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2674             }
2675             else {
2676             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2677             }
2678             if ($length == 0) {
2679             $octet_length = 0;
2680             }
2681             elsif ($length > 0) {
2682             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2683             }
2684             else {
2685             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2686             }
2687             CORE::substr($_[0], $octet_offset, $octet_length);
2688             }
2689              
2690             # substr($string,$offset)
2691             else {
2692             my $octet_offset = 0;
2693             if ($offset == 0) {
2694             $octet_offset = 0;
2695             }
2696             elsif ($offset > 0) {
2697             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2698             }
2699             else {
2700             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2701             }
2702             CORE::substr($_[0], $octet_offset);
2703             }
2704             }
2705             END
2706             }
2707              
2708             #
2709             # US-ASCII index by character
2710             #
2711 0     0 1 0 sub USASCII::index($$;$) {
2712 0 0       0  
2713 0         0 my $index;
2714             if (@_ == 3) {
2715             $index = Eusascii::index($_[0], $_[1], CORE::length(USASCII::substr($_[0], 0, $_[2])));
2716 0         0 }
2717             else {
2718             $index = Eusascii::index($_[0], $_[1]);
2719 0 0       0 }
2720 0         0  
2721             if ($index == -1) {
2722             return -1;
2723 0         0 }
2724             else {
2725             return USASCII::length(CORE::substr $_[0], 0, $index);
2726             }
2727             }
2728              
2729             #
2730             # US-ASCII rindex by character
2731             #
2732 0     0 1 0 sub USASCII::rindex($$;$) {
2733 0 0       0  
2734 0         0 my $rindex;
2735             if (@_ == 3) {
2736             $rindex = Eusascii::rindex($_[0], $_[1], CORE::length(USASCII::substr($_[0], 0, $_[2])));
2737 0         0 }
2738             else {
2739             $rindex = Eusascii::rindex($_[0], $_[1]);
2740 0 0       0 }
2741 0         0  
2742             if ($rindex == -1) {
2743             return -1;
2744 0         0 }
2745             else {
2746             return USASCII::length(CORE::substr $_[0], 0, $rindex);
2747             }
2748             }
2749              
2750 204     204   1754 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         440  
  204         24436  
2751             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2752             use vars qw($slash); $slash = 'm//';
2753              
2754             # ord() to ord() or USASCII::ord()
2755             my $function_ord = 'ord';
2756              
2757             # ord to ord or USASCII::ord_
2758             my $function_ord_ = 'ord';
2759              
2760             # reverse to reverse or USASCII::reverse
2761             my $function_reverse = 'reverse';
2762              
2763             # getc to getc or USASCII::getc
2764             my $function_getc = 'getc';
2765              
2766             # P.1023 Appendix W.9 Multibyte Anchoring
2767             # of ISBN 1-56592-224-7 CJKV Information Processing
2768              
2769 204     204   1478 my $anchor = '';
  204     0   367  
  204         8077842  
2770              
2771             use vars qw($nest);
2772              
2773             # regexp of nested parens in qqXX
2774              
2775             # P.340 Matching Nested Constructs with Embedded Code
2776             # in Chapter 7: Perl
2777             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2778              
2779             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2780             [^\\()] |
2781             \( (?{$nest++}) |
2782             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2783             \\ [^c] |
2784             \\c[\x40-\x5F] |
2785             [\x00-\xFF]
2786             }xms;
2787              
2788             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2789             [^\\{}] |
2790             \{ (?{$nest++}) |
2791             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2792             \\ [^c] |
2793             \\c[\x40-\x5F] |
2794             [\x00-\xFF]
2795             }xms;
2796              
2797             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2798             [^\\\[\]] |
2799             \[ (?{$nest++}) |
2800             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2801             \\ [^c] |
2802             \\c[\x40-\x5F] |
2803             [\x00-\xFF]
2804             }xms;
2805              
2806             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2807             [^\\<>] |
2808             \< (?{$nest++}) |
2809             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2810             \\ [^c] |
2811             \\c[\x40-\x5F] |
2812             [\x00-\xFF]
2813             }xms;
2814              
2815             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2816             (?: ::)? (?:
2817             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2818             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2819             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2820             ))
2821             }xms;
2822              
2823             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2824             (?: ::)? (?:
2825             (?>[0-9]+) |
2826             [^a-zA-Z_0-9\[\]] |
2827             ^[A-Z] |
2828             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2829             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2830             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2831             ))
2832             }xms;
2833              
2834             my $qq_substr = qr{(?> Char::substr | USASCII::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2835             }xms;
2836              
2837             # regexp of nested parens in qXX
2838             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2839             [^()] |
2840             \( (?{$nest++}) |
2841             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2842             [\x00-\xFF]
2843             }xms;
2844              
2845             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2846             [^\{\}] |
2847             \{ (?{$nest++}) |
2848             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2849             [\x00-\xFF]
2850             }xms;
2851              
2852             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2853             [^\[\]] |
2854             \[ (?{$nest++}) |
2855             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2856             [\x00-\xFF]
2857             }xms;
2858              
2859             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2860             [^<>] |
2861             \< (?{$nest++}) |
2862             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2863             [\x00-\xFF]
2864             }xms;
2865              
2866             my $matched = '';
2867             my $s_matched = '';
2868              
2869             my $tr_variable = ''; # variable of tr///
2870             my $sub_variable = ''; # variable of s///
2871             my $bind_operator = ''; # =~ or !~
2872              
2873             my @heredoc = (); # here document
2874             my @heredoc_delimiter = ();
2875             my $here_script = ''; # here script
2876              
2877             #
2878             # escape US-ASCII script
2879 0 50   204 0 0 #
2880             sub USASCII::escape(;$) {
2881             local($_) = $_[0] if @_;
2882              
2883             # P.359 The Study Function
2884             # in Chapter 7: Perl
2885 204         625 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2886              
2887             study $_; # Yes, I studied study yesterday.
2888              
2889             # while all script
2890              
2891             # 6.14. Matching from Where the Last Pattern Left Off
2892             # in Chapter 6. Pattern Matching
2893             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2894             # (and so on)
2895              
2896             # one member of Tag-team
2897             #
2898             # P.128 Start of match (or end of previous match): \G
2899             # P.130 Advanced Use of \G with Perl
2900             # in Chapter 3: Overview of Regular Expression Features and Flavors
2901             # P.255 Use leading anchors
2902             # P.256 Expose ^ and \G at the front expressions
2903             # in Chapter 6: Crafting an Efficient Expression
2904             # P.315 "Tag-team" matching with /gc
2905             # in Chapter 7: Perl
2906 204         474 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2907 204         355  
2908 204         759 my $e_script = '';
2909             while (not /\G \z/oxgc) { # member
2910             $e_script .= USASCII::escape_token();
2911 73227         109792 }
2912              
2913             return $e_script;
2914             }
2915              
2916             #
2917             # escape US-ASCII token of script
2918             #
2919             sub USASCII::escape_token {
2920              
2921 204     73227 0 2646 # \n output here document
2922              
2923             my $ignore_modules = join('|', qw(
2924             utf8
2925             bytes
2926             charnames
2927             I18N::Japanese
2928             I18N::Collate
2929             I18N::JExt
2930             File::DosGlob
2931             Wild
2932             Wildcard
2933             Japanese
2934             ));
2935              
2936             # another member of Tag-team
2937             #
2938             # P.315 "Tag-team" matching with /gc
2939             # in Chapter 7: Perl
2940 73227 100 100     85591 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    100 66        
    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          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    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          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
2941 73227         2670644  
2942 12245 100       15409 if (/\G ( \n ) /oxgc) { # another member (and so on)
2943 12245         20701 my $heredoc = '';
2944             if (scalar(@heredoc_delimiter) >= 1) {
2945 174         228 $slash = 'm//';
2946 174         331  
2947             $heredoc = join '', @heredoc;
2948             @heredoc = ();
2949 174         284  
2950 174         289 # skip here document
2951             for my $heredoc_delimiter (@heredoc_delimiter) {
2952 174         1068 /\G .*? \n $heredoc_delimiter \n/xmsgc;
2953             }
2954 174         331 @heredoc_delimiter = ();
2955              
2956 174         242 $here_script = '';
2957             }
2958             return "\n" . $heredoc;
2959             }
2960 12245         35208  
2961             # ignore space, comment
2962             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
2963              
2964             # if (, elsif (, unless (, while (, until (, given (, and when (
2965              
2966             # given, when
2967              
2968             # P.225 The given Statement
2969             # in Chapter 15: Smart Matching and given-when
2970             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
2971              
2972             # P.133 The given Statement
2973             # in Chapter 4: Statements and Declarations
2974             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2975 17216         51501  
2976 1379         2022 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
2977             $slash = 'm//';
2978             return $1;
2979             }
2980              
2981             # scalar variable ($scalar = ...) =~ tr///;
2982             # scalar variable ($scalar = ...) =~ s///;
2983              
2984             # state
2985              
2986             # P.68 Persistent, Private Variables
2987             # in Chapter 4: Subroutines
2988             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
2989              
2990             # P.160 Persistent Lexically Scoped Variables: state
2991             # in Chapter 4: Statements and Declarations
2992             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2993              
2994             # (and so on)
2995 1379         4160  
2996             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
2997 86 50       200 my $e_string = e_string($1);
    50          
2998 86         2049  
2999 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3000 0         0 $tr_variable = $e_string . e_string($1);
3001 0         0 $bind_operator = $2;
3002             $slash = 'm//';
3003             return '';
3004 0         0 }
3005 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3006 0         0 $sub_variable = $e_string . e_string($1);
3007 0         0 $bind_operator = $2;
3008             $slash = 'm//';
3009             return '';
3010 0         0 }
3011 86         153 else {
3012             $slash = 'div';
3013             return $e_string;
3014             }
3015             }
3016              
3017 86         295 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
3018 4         8 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3019             $slash = 'div';
3020             return q{Eusascii::PREMATCH()};
3021             }
3022              
3023 4         12 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
3024 28         260 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3025             $slash = 'div';
3026             return q{Eusascii::MATCH()};
3027             }
3028              
3029 28         108 # $', ${'} --> $', ${'}
3030 1         3 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3031             $slash = 'div';
3032             return $1;
3033             }
3034              
3035 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
3036 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3037             $slash = 'div';
3038             return q{Eusascii::POSTMATCH()};
3039             }
3040              
3041             # scalar variable $scalar =~ tr///;
3042             # scalar variable $scalar =~ s///;
3043             # substr() =~ tr///;
3044 3         11 # substr() =~ s///;
3045             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3046 1668 100       3564 my $scalar = e_string($1);
    100          
3047 1668         6186  
3048 1         3 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3049 1         2 $tr_variable = $scalar;
3050 1         2 $bind_operator = $1;
3051             $slash = 'm//';
3052             return '';
3053 1         3 }
3054 61         429 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3055 61         124 $sub_variable = $scalar;
3056 61         105 $bind_operator = $1;
3057             $slash = 'm//';
3058             return '';
3059 61         191 }
3060 1606         2321 else {
3061             $slash = 'div';
3062             return $scalar;
3063             }
3064             }
3065              
3066 1606         4277 # end of statement
3067             elsif (/\G ( [,;] ) /oxgc) {
3068             $slash = 'm//';
3069 4831         7319  
3070             # clear tr/// variable
3071             $tr_variable = '';
3072 4831         5730  
3073             # clear s/// variable
3074 4831         5570 $sub_variable = '';
3075              
3076 4831         5385 $bind_operator = '';
3077              
3078             return $1;
3079             }
3080              
3081 4831         15854 # bareword
3082             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3083             return $1;
3084             }
3085              
3086 0         0 # $0 --> $0
3087 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
3088             $slash = 'div';
3089             return $1;
3090 2         8 }
3091 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3092             $slash = 'div';
3093             return $1;
3094             }
3095              
3096 0         0 # $$ --> $$
3097 1         2 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3098             $slash = 'div';
3099             return $1;
3100             }
3101              
3102             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3103 1         5 # $1, $2, $3 --> $1, $2, $3 otherwise
3104 4         8 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3105             $slash = 'div';
3106             return e_capture($1);
3107 4         9 }
3108 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3109             $slash = 'div';
3110             return e_capture($1);
3111             }
3112              
3113 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3114 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3115             $slash = 'div';
3116             return e_capture($1.'->'.$2);
3117             }
3118              
3119 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3120 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3121             $slash = 'div';
3122             return e_capture($1.'->'.$2);
3123             }
3124              
3125 0         0 # $$foo
3126 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3127             $slash = 'div';
3128             return e_capture($1);
3129             }
3130              
3131 0         0 # ${ foo }
3132 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3133             $slash = 'div';
3134             return '${' . $1 . '}';
3135             }
3136              
3137 0         0 # ${ ... }
3138 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3139             $slash = 'div';
3140             return e_capture($1);
3141             }
3142              
3143             # variable or function
3144 0         0 # $ @ % & * $ #
3145 32         60 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) {
3146             $slash = 'div';
3147             return $1;
3148             }
3149             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3150 32         101 # $ @ # \ ' " / ? ( ) [ ] < >
3151 62         124 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3152             $slash = 'div';
3153             return $1;
3154             }
3155              
3156 62         221 # while ()
3157             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3158             return $1;
3159             }
3160              
3161             # while () --- glob
3162              
3163             # avoid "Error: Runtime exception" of perl version 5.005_03
3164 0         0  
3165             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3166             return 'while ($_ = Eusascii::glob("' . $1 . '"))';
3167             }
3168              
3169 0         0 # while (glob)
3170             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3171             return 'while ($_ = Eusascii::glob_)';
3172             }
3173              
3174 0         0 # while (glob(WILDCARD))
3175             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3176             return 'while ($_ = Eusascii::glob';
3177             }
3178 0         0  
  248         554  
3179             # doit if, doit unless, doit while, doit until, doit for, doit when
3180             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3181 248         860  
  19         50  
3182 19         77 # subroutines of package Eusascii
  0         0  
3183 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         17  
3184 13         33 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3185 0         0 elsif (/\G \b USASCII::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         171  
3186 114         300 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         4  
3187 2         7 elsif (/\G \b USASCII::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval USASCII::escape'; }
  0         0  
3188 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         5  
3189 2         7 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::chop'; }
  0         0  
3190 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3191 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3192 0         0 elsif (/\G \b USASCII::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'USASCII::index'; }
  2         5  
3193 2         9 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::index'; }
  0         0  
3194 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3195 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3196 0         0 elsif (/\G \b USASCII::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'USASCII::rindex'; }
  1         2  
3197 1         13 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::rindex'; }
  0         0  
3198 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::lc'; }
  1         2  
3199 1         3 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::lcfirst'; }
  0         0  
3200 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::uc'; }
  2         4  
3201             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::ucfirst'; }
3202             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::fc'; }
3203 2         5  
  0         0  
3204 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3205 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3206 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3207 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3208 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3209 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3210             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3211 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  
3212 0         0  
  0         0  
3213 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3214 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3215 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3216 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3217 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3218             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3219             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3220 0         0  
  0         0  
3221 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3222 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3223 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3224             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3225 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         6  
3226 2         8  
  2         5  
3227 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         64  
3228 36         122 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         4  
3229 2         8 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::chr'; }
  8         16  
3230 8         26 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3231 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3232 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::glob'; }
  0         0  
3233 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::lc_'; }
  0         0  
3234 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::lcfirst_'; }
  0         0  
3235 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::uc_'; }
  0         0  
3236 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::ucfirst_'; }
  0         0  
3237             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::fc_'; }
3238 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3239 0         0  
  0         0  
3240 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3241 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3242 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::chr_'; }
  0         0  
3243 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3244 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3245 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::glob_'; }
  8         17  
3246             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3247             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3248 8         28 # split
3249             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3250 87         182 $slash = 'm//';
3251 87         144  
3252 87         325 my $e = '';
3253             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3254             $e .= $1;
3255             }
3256 85 100       327  
  87 100       5942  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3257             # end of split
3258             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Eusascii::split' . $e; }
3259 2         8  
3260             # split scalar value
3261             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Eusascii::split' . $e . e_string($1); }
3262 1         6  
3263 0         0 # split literal space
3264 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Eusascii::split' . $e . qq {qq$1 $2}; }
3265 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Eusascii::split' . $e . qq{$1qq$2 $3}; }
3266 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Eusascii::split' . $e . qq{$1qq$2 $3}; }
3267 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Eusascii::split' . $e . qq{$1qq$2 $3}; }
3268 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Eusascii::split' . $e . qq{$1qq$2 $3}; }
3269 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Eusascii::split' . $e . qq{$1qq$2 $3}; }
3270 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Eusascii::split' . $e . qq {q$1 $2}; }
3271 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Eusascii::split' . $e . qq {$1q$2 $3}; }
3272 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Eusascii::split' . $e . qq {$1q$2 $3}; }
3273 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Eusascii::split' . $e . qq {$1q$2 $3}; }
3274 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Eusascii::split' . $e . qq {$1q$2 $3}; }
3275 10         50 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Eusascii::split' . $e . qq {$1q$2 $3}; }
3276             elsif (/\G ' [ ] ' /oxgc) { return 'Eusascii::split' . $e . qq {' '}; }
3277             elsif (/\G " [ ] " /oxgc) { return 'Eusascii::split' . $e . qq {" "}; }
3278              
3279 0 0       0 # split qq//
  0         0  
3280             elsif (/\G \b (qq) \b /oxgc) {
3281 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3282 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3283 0         0 while (not /\G \z/oxgc) {
3284 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3285 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3286 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3287 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3288 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3289             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3290 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3291             }
3292             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3293             }
3294             }
3295              
3296 0 50       0 # split qr//
  12         443  
3297             elsif (/\G \b (qr) \b /oxgc) {
3298 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3299 12 50       67 else {
  12 50       3496  
    50          
    50          
    50          
    50          
    50          
    50          
3300 0         0 while (not /\G \z/oxgc) {
3301 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3302 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3303 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3304 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3305 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3306 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3307             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3308 12         97 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3309             }
3310             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3311             }
3312             }
3313              
3314 0 0       0 # split q//
  0         0  
3315             elsif (/\G \b (q) \b /oxgc) {
3316 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3317 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3318 0         0 while (not /\G \z/oxgc) {
3319 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3320 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3321 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3322 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3323 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3324             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3325 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3326             }
3327             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3328             }
3329             }
3330              
3331 0 50       0 # split m//
  18         495  
3332             elsif (/\G \b (m) \b /oxgc) {
3333 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3334 18 50       79 else {
  18 50       3831  
    50          
    50          
    50          
    50          
    50          
    50          
3335 0         0 while (not /\G \z/oxgc) {
3336 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3337 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3338 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3339 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3340 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3341 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3342             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3343 18         114 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3344             }
3345             die __FILE__, ": Search pattern not terminated\n";
3346             }
3347             }
3348              
3349 0         0 # split ''
3350 0         0 elsif (/\G (\') /oxgc) {
3351 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3352 0         0 while (not /\G \z/oxgc) {
3353 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3354 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3355             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3356 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3357             }
3358             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3359             }
3360              
3361 0         0 # split ""
3362 0         0 elsif (/\G (\") /oxgc) {
3363 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3364 0         0 while (not /\G \z/oxgc) {
3365 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3366 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3367             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3368 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3369             }
3370             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3371             }
3372              
3373 0         0 # split //
3374 44         127 elsif (/\G (\/) /oxgc) {
3375 44 50       163 my $regexp = '';
  381 50       1532  
    100          
    50          
3376 0         0 while (not /\G \z/oxgc) {
3377 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3378 44         185 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3379             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3380 337         694 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3381             }
3382             die __FILE__, ": Search pattern not terminated\n";
3383             }
3384             }
3385              
3386             # tr/// or y///
3387              
3388             # about [cdsrbB]* (/B modifier)
3389             #
3390             # P.559 appendix C
3391             # of ISBN 4-89052-384-7 Programming perl
3392             # (Japanese title is: Perl puroguramingu)
3393 0         0  
3394             elsif (/\G \b ( tr | y ) \b /oxgc) {
3395             my $ope = $1;
3396 3 50       8  
3397 3         40 # $1 $2 $3 $4 $5 $6
3398 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3399             my @tr = ($tr_variable,$2);
3400             return e_tr(@tr,'',$4,$6);
3401 0         0 }
3402 3         5 else {
3403 3 50       11 my $e = '';
  3 50       234  
    50          
    50          
    50          
    50          
3404             while (not /\G \z/oxgc) {
3405 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3406 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3407 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3408 0         0 while (not /\G \z/oxgc) {
3409 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3410 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3411 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3412 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3413             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3414 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3415             }
3416             die __FILE__, ": Transliteration replacement not terminated\n";
3417 0         0 }
3418 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3419 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3420 0         0 while (not /\G \z/oxgc) {
3421 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3422 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3423 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3424 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3425             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3426 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3427             }
3428             die __FILE__, ": Transliteration replacement not terminated\n";
3429 0         0 }
3430 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3431 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3432 0         0 while (not /\G \z/oxgc) {
3433 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3434 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3435 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3436 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3437             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3438 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3439             }
3440             die __FILE__, ": Transliteration replacement not terminated\n";
3441 0         0 }
3442 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3443 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3444 0         0 while (not /\G \z/oxgc) {
3445 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3446 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3447 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3448 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3449             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3450 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3451             }
3452             die __FILE__, ": Transliteration replacement not terminated\n";
3453             }
3454 0         0 # $1 $2 $3 $4 $5 $6
3455 3         11 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3456             my @tr = ($tr_variable,$2);
3457             return e_tr(@tr,'',$4,$6);
3458 3         9 }
3459             }
3460             die __FILE__, ": Transliteration pattern not terminated\n";
3461             }
3462             }
3463              
3464 0         0 # qq//
3465             elsif (/\G \b (qq) \b /oxgc) {
3466             my $ope = $1;
3467 2136 50       4658  
3468 2136         3813 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3469 0         0 if (/\G (\#) /oxgc) { # qq# #
3470 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3471 0         0 while (not /\G \z/oxgc) {
3472 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3473 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3474             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3475 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3476             }
3477             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3478             }
3479 0         0  
3480 2136         2825 else {
3481 2136 50       4799 my $e = '';
  2136 50       10075  
    100          
    50          
    50          
    0          
3482             while (not /\G \z/oxgc) {
3483             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3484              
3485 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3486 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3487 0         0 my $qq_string = '';
3488 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3489 0         0 while (not /\G \z/oxgc) {
3490 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3491             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3492 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3493 0         0 elsif (/\G (\)) /oxgc) {
3494             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3495 0         0 else { $qq_string .= $1; }
3496             }
3497 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3498             }
3499             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3500             }
3501              
3502 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3503 2106         2842 elsif (/\G (\{) /oxgc) { # qq { }
3504 2106         2890 my $qq_string = '';
3505 2106 100       4193 local $nest = 1;
  83317 50       249386  
    100          
    100          
    50          
3506 610         1236 while (not /\G \z/oxgc) {
3507 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1173         1641  
3508             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3509 1173 100       2044 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3279         5260  
3510 2106         4113 elsif (/\G (\}) /oxgc) {
3511             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3512 1173         2324 else { $qq_string .= $1; }
3513             }
3514 78255         149856 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3515             }
3516             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3517             }
3518              
3519 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3520 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3521 0         0 my $qq_string = '';
3522 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3523 0         0 while (not /\G \z/oxgc) {
3524 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3525             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3526 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3527 0         0 elsif (/\G (\]) /oxgc) {
3528             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3529 0         0 else { $qq_string .= $1; }
3530             }
3531 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3532             }
3533             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3534             }
3535              
3536 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3537 30         48 elsif (/\G (\<) /oxgc) { # qq < >
3538 30         48 my $qq_string = '';
3539 30 100       92 local $nest = 1;
  1166 50       3933  
    50          
    100          
    50          
3540 22         52 while (not /\G \z/oxgc) {
3541 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3542             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3543 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         56  
3544 30         105 elsif (/\G (\>) /oxgc) {
3545             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3546 0         0 else { $qq_string .= $1; }
3547             }
3548 1114         2104 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3549             }
3550             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3551             }
3552              
3553 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3554 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3555 0         0 my $delimiter = $1;
3556 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3557 0         0 while (not /\G \z/oxgc) {
3558 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3559 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3560             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3561 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3562             }
3563             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3564 0         0 }
3565             }
3566             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3567             }
3568             }
3569              
3570 0         0 # qr//
3571 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3572 0         0 my $ope = $1;
3573             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3574             return e_qr($ope,$1,$3,$2,$4);
3575 0         0 }
3576 0         0 else {
3577 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3578 0         0 while (not /\G \z/oxgc) {
3579 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3580 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3581 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3582 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3583 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3584 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3585             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3586 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3587             }
3588             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3589             }
3590             }
3591              
3592 0         0 # qw//
3593 14 50       54 elsif (/\G \b (qw) \b /oxgc) {
3594 14         95 my $ope = $1;
3595             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3596             return e_qw($ope,$1,$3,$2);
3597 0         0 }
3598 14         28 else {
3599 14 50       45 my $e = '';
  14 50       81  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3600             while (not /\G \z/oxgc) {
3601 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3602 14         47  
3603             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3604 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3605 0         0  
3606             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3607 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3608 0         0  
3609             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3610 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3611 0         0  
3612             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3613 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3614 0         0  
3615             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3616 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3617             }
3618             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3619             }
3620             }
3621              
3622 0         0 # qx//
3623 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3624 0         0 my $ope = $1;
3625             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3626             return e_qq($ope,$1,$3,$2);
3627 0         0 }
3628 0         0 else {
3629 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3630 0         0 while (not /\G \z/oxgc) {
3631 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3632 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3633 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3634 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3635 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3636             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3637 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3638             }
3639             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3640             }
3641             }
3642              
3643 0         0 # q//
3644             elsif (/\G \b (q) \b /oxgc) {
3645             my $ope = $1;
3646              
3647             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3648              
3649             # avoid "Error: Runtime exception" of perl version 5.005_03
3650 422 50       1118 # (and so on)
3651 422         1008  
3652 0         0 if (/\G (\#) /oxgc) { # q# #
3653 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3654 0         0 while (not /\G \z/oxgc) {
3655 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3656 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3657             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3658 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3659             }
3660             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3661             }
3662 0         0  
3663 422         664 else {
3664 422 50       1249 my $e = '';
  422 50       2172  
    100          
    50          
    100          
    50          
3665             while (not /\G \z/oxgc) {
3666             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3667              
3668 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3669 0         0 elsif (/\G (\() /oxgc) { # q ( )
3670 0         0 my $q_string = '';
3671 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3672 0         0 while (not /\G \z/oxgc) {
3673 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3674 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3675             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3676 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3677 0         0 elsif (/\G (\)) /oxgc) {
3678             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3679 0         0 else { $q_string .= $1; }
3680             }
3681 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3682             }
3683             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3684             }
3685              
3686 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3687 416         673 elsif (/\G (\{) /oxgc) { # q { }
3688 416         674 my $q_string = '';
3689 416 50       1048 local $nest = 1;
  9795 50       32576  
    50          
    100          
    100          
    50          
3690 0         0 while (not /\G \z/oxgc) {
3691 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3692 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  149         204  
3693             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3694 149 100       252 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  565         1161  
3695 416         1063 elsif (/\G (\}) /oxgc) {
3696             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3697 149         282 else { $q_string .= $1; }
3698             }
3699 9081         16987 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3700             }
3701             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3702             }
3703              
3704 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3705 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3706 0         0 my $q_string = '';
3707 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3708 0         0 while (not /\G \z/oxgc) {
3709 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3710 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3711             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3712 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3713 0         0 elsif (/\G (\]) /oxgc) {
3714             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3715 0         0 else { $q_string .= $1; }
3716             }
3717 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3718             }
3719             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3720             }
3721              
3722 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3723 5         11 elsif (/\G (\<) /oxgc) { # q < >
3724 5         10 my $q_string = '';
3725 5 50       18 local $nest = 1;
  88 50       370  
    50          
    50          
    100          
    50          
3726 0         0 while (not /\G \z/oxgc) {
3727 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3728 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3729             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3730 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         11  
3731 5         15 elsif (/\G (\>) /oxgc) {
3732             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3733 0         0 else { $q_string .= $1; }
3734             }
3735 83         164 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3736             }
3737             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3738             }
3739              
3740 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3741 1         2 elsif (/\G (\S) /oxgc) { # q * *
3742 1         2 my $delimiter = $1;
3743 1 50       3 my $q_string = '';
  14 50       76  
    100          
    50          
3744 0         0 while (not /\G \z/oxgc) {
3745 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3746 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3747             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3748 13         30 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3749             }
3750             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3751 0         0 }
3752             }
3753             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3754             }
3755             }
3756              
3757 0         0 # m//
3758 209 50       537 elsif (/\G \b (m) \b /oxgc) {
3759 209         1323 my $ope = $1;
3760             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3761             return e_qr($ope,$1,$3,$2,$4);
3762 0         0 }
3763 209         332 else {
3764 209 50       567 my $e = '';
  209 50       10540  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3765 0         0 while (not /\G \z/oxgc) {
3766 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3767 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3768 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3769 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3770 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3771 10         25 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3772 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3773             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3774 199         695 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3775             }
3776             die __FILE__, ": Search pattern not terminated\n";
3777             }
3778             }
3779              
3780             # s///
3781              
3782             # about [cegimosxpradlunbB]* (/cg modifier)
3783             #
3784             # P.67 Pattern-Matching Operators
3785             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3786 0         0  
3787             elsif (/\G \b (s) \b /oxgc) {
3788             my $ope = $1;
3789 97 100       244  
3790 97         1613 # $1 $2 $3 $4 $5 $6
3791             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3792             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3793 1         5 }
3794 96         220 else {
3795 96 50       301 my $e = '';
  96 50       11652  
    50          
    50          
    50          
    100          
    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 @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3800             while (not /\G \z/oxgc) {
3801 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3802 0         0 # $1 $2 $3 $4
3803 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3804 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3805 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3806 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3807 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3808 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3809 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3810             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3811 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3812             }
3813             die __FILE__, ": Substitution replacement not terminated\n";
3814 0         0 }
3815 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3816 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3817             while (not /\G \z/oxgc) {
3818 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3819 0         0 # $1 $2 $3 $4
3820 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3821 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3822 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3823 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3824 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3825 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3826 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3827             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3828 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3829             }
3830             die __FILE__, ": Substitution replacement not terminated\n";
3831 0         0 }
3832 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3833 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3834             while (not /\G \z/oxgc) {
3835 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3836 0         0 # $1 $2 $3 $4
3837 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3838 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3839 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3840 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3841 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3842             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3843 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3844             }
3845             die __FILE__, ": Substitution replacement not terminated\n";
3846 0         0 }
3847 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3848 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3849             while (not /\G \z/oxgc) {
3850 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3851 0         0 # $1 $2 $3 $4
3852 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3853 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3854 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3855 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3856 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3857 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3858 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3859             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3860 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3861             }
3862             die __FILE__, ": Substitution replacement not terminated\n";
3863             }
3864 0         0 # $1 $2 $3 $4 $5 $6
3865             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3866             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3867             }
3868 21         72 # $1 $2 $3 $4 $5 $6
3869             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3870             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3871             }
3872 0         0 # $1 $2 $3 $4 $5 $6
3873             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3874             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3875             }
3876 0         0 # $1 $2 $3 $4 $5 $6
3877             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3878             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3879 75         320 }
3880             }
3881             die __FILE__, ": Substitution pattern not terminated\n";
3882             }
3883             }
3884 0         0  
3885 0         0 # require ignore module
3886 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3887             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3888             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3889 0         0  
3890 37         294 # use strict; --> use strict; no strict qw(refs);
3891 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3892             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
3893             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
3894              
3895 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
3896 2         20 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
3897             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
3898             return "use $1; no strict qw(refs);";
3899 0         0 }
3900             else {
3901             return "use $1;";
3902             }
3903 2 0 0     11 }
      0        
3904 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
3905             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
3906             return "use $1; no strict qw(refs);";
3907 0         0 }
3908             else {
3909             return "use $1;";
3910             }
3911             }
3912 0         0  
3913 2         17 # ignore use module
3914 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
3915             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
3916             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
3917 0         0  
3918 0         0 # ignore no module
3919 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
3920             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
3921             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
3922 0         0  
3923             # use else
3924             elsif (/\G \b use \b /oxmsgc) { return "use"; }
3925 0         0  
3926             # use else
3927             elsif (/\G \b no \b /oxmsgc) { return "no"; }
3928              
3929 2         7 # ''
3930 836         1744 elsif (/\G (?
3931 836 100       2122 my $q_string = '';
  9499 100       28517  
    100          
    50          
3932 4         10 while (not /\G \z/oxgc) {
3933 12         25 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3934 836         1879 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
3935             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
3936 8647         17031 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3937             }
3938             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3939             }
3940              
3941 0         0 # ""
3942 1552         2993 elsif (/\G (\") /oxgc) {
3943 1552 100       3692 my $qq_string = '';
  36223 100       98568  
    100          
    50          
3944 67         156 while (not /\G \z/oxgc) {
3945 12         25 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3946 1552         3348 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
3947             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
3948 34592         65909 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3949             }
3950             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3951             }
3952              
3953 0         0 # ``
3954 1         3 elsif (/\G (\`) /oxgc) {
3955 1 50       4 my $qx_string = '';
  19 50       63  
    100          
    50          
3956 0         0 while (not /\G \z/oxgc) {
3957 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
3958 1         3 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
3959             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
3960 18         35 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
3961             }
3962             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3963             }
3964              
3965 0         0 # // --- not divide operator (num / num), not defined-or
3966 425         930 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
3967 425 50       1131 my $regexp = '';
  4222 50       13974  
    100          
    50          
3968 0         0 while (not /\G \z/oxgc) {
3969 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3970 425         1076 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
3971             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
3972 3797         8125 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3973             }
3974             die __FILE__, ": Search pattern not terminated\n";
3975             }
3976              
3977 0         0 # ?? --- not conditional operator (condition ? then : else)
3978 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
3979 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
3980 0         0 while (not /\G \z/oxgc) {
3981 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3982 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
3983             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
3984 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3985             }
3986             die __FILE__, ": Search pattern not terminated\n";
3987             }
3988 0         0  
  0         0  
3989             # <<>> (a safer ARGV)
3990             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
3991 0         0  
  0         0  
3992             # << (bit shift) --- not here document
3993             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
3994              
3995 0         0 # <<~'HEREDOC'
3996 6         11 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
3997 6         12 $slash = 'm//';
3998             my $here_quote = $1;
3999             my $delimiter = $2;
4000 6 50       9  
4001 6         12 # get here document
4002 6         28 if ($here_script eq '') {
4003             $here_script = CORE::substr $_, pos $_;
4004 6 50       29 $here_script =~ s/.*?\n//oxm;
4005 6         91 }
4006 6         16 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4007 6         9 my $heredoc = $1;
4008 6         45 my $indent = $2;
4009 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
4010             push @heredoc, $heredoc . qq{\n$delimiter\n};
4011             push @heredoc_delimiter, qq{\\s*$delimiter};
4012 6         11 }
4013             else {
4014 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4015             }
4016             return qq{<<'$delimiter'};
4017             }
4018              
4019             # <<~\HEREDOC
4020              
4021             # P.66 2.6.6. "Here" Documents
4022             # in Chapter 2: Bits and Pieces
4023             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4024              
4025             # P.73 "Here" Documents
4026             # in Chapter 2: Bits and Pieces
4027             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4028 6         24  
4029 3         15 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4030 3         8 $slash = 'm//';
4031             my $here_quote = $1;
4032             my $delimiter = $2;
4033 3 50       5  
4034 3         7 # get here document
4035 3         11 if ($here_script eq '') {
4036             $here_script = CORE::substr $_, pos $_;
4037 3 50       21 $here_script =~ s/.*?\n//oxm;
4038 3         38 }
4039 3         6 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4040 3         5 my $heredoc = $1;
4041 3         33 my $indent = $2;
4042 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
4043             push @heredoc, $heredoc . qq{\n$delimiter\n};
4044             push @heredoc_delimiter, qq{\\s*$delimiter};
4045 3         7 }
4046             else {
4047 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4048             }
4049             return qq{<<\\$delimiter};
4050             }
4051              
4052 3         12 # <<~"HEREDOC"
4053 6         13 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4054 6         12 $slash = 'm//';
4055             my $here_quote = $1;
4056             my $delimiter = $2;
4057 6 50       8  
4058 6         13 # get here document
4059 6         19 if ($here_script eq '') {
4060             $here_script = CORE::substr $_, pos $_;
4061 6 50       29 $here_script =~ s/.*?\n//oxm;
4062 6         61 }
4063 6         12 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4064 6         8 my $heredoc = $1;
4065 6         47 my $indent = $2;
4066 6         26 $heredoc =~ s{^$indent}{}msg; # no /ox
4067             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4068             push @heredoc_delimiter, qq{\\s*$delimiter};
4069 6         14 }
4070             else {
4071 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4072             }
4073             return qq{<<"$delimiter"};
4074             }
4075              
4076 6         25 # <<~HEREDOC
4077 3         6 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4078 3         16 $slash = 'm//';
4079             my $here_quote = $1;
4080             my $delimiter = $2;
4081 3 50       5  
4082 3         7 # get here document
4083 3         18 if ($here_script eq '') {
4084             $here_script = CORE::substr $_, pos $_;
4085 3 50       21 $here_script =~ s/.*?\n//oxm;
4086 3         37 }
4087 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4088 3         6 my $heredoc = $1;
4089 3         36 my $indent = $2;
4090 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
4091             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4092             push @heredoc_delimiter, qq{\\s*$delimiter};
4093 3         7 }
4094             else {
4095 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4096             }
4097             return qq{<<$delimiter};
4098             }
4099              
4100 3         12 # <<~`HEREDOC`
4101 6         13 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4102 6         11 $slash = 'm//';
4103             my $here_quote = $1;
4104             my $delimiter = $2;
4105 6 50       10  
4106 6         11 # get here document
4107 6         26 if ($here_script eq '') {
4108             $here_script = CORE::substr $_, pos $_;
4109 6 50       28 $here_script =~ s/.*?\n//oxm;
4110 6         52 }
4111 6         18 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4112 6         11 my $heredoc = $1;
4113 6         45 my $indent = $2;
4114 6         16 $heredoc =~ s{^$indent}{}msg; # no /ox
4115             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4116             push @heredoc_delimiter, qq{\\s*$delimiter};
4117 6         12 }
4118             else {
4119 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4120             }
4121             return qq{<<`$delimiter`};
4122             }
4123              
4124 6         31 # <<'HEREDOC'
4125 72         137 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4126 72         141 $slash = 'm//';
4127             my $here_quote = $1;
4128             my $delimiter = $2;
4129 72 50       111  
4130 72         138 # get here document
4131 72         372 if ($here_script eq '') {
4132             $here_script = CORE::substr $_, pos $_;
4133 72 50       404 $here_script =~ s/.*?\n//oxm;
4134 72         536 }
4135 72         224 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4136             push @heredoc, $1 . qq{\n$delimiter\n};
4137             push @heredoc_delimiter, $delimiter;
4138 72         115 }
4139             else {
4140 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4141             }
4142             return $here_quote;
4143             }
4144              
4145             # <<\HEREDOC
4146              
4147             # P.66 2.6.6. "Here" Documents
4148             # in Chapter 2: Bits and Pieces
4149             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4150              
4151             # P.73 "Here" Documents
4152             # in Chapter 2: Bits and Pieces
4153             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4154 72         302  
4155 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4156 0         0 $slash = 'm//';
4157             my $here_quote = $1;
4158             my $delimiter = $2;
4159 0 0       0  
4160 0         0 # get here document
4161 0         0 if ($here_script eq '') {
4162             $here_script = CORE::substr $_, pos $_;
4163 0 0       0 $here_script =~ s/.*?\n//oxm;
4164 0         0 }
4165 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4166             push @heredoc, $1 . qq{\n$delimiter\n};
4167             push @heredoc_delimiter, $delimiter;
4168 0         0 }
4169             else {
4170 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4171             }
4172             return $here_quote;
4173             }
4174              
4175 0         0 # <<"HEREDOC"
4176 36         88 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4177 36         84 $slash = 'm//';
4178             my $here_quote = $1;
4179             my $delimiter = $2;
4180 36 50       69  
4181 36         95 # get here document
4182 36         307 if ($here_script eq '') {
4183             $here_script = CORE::substr $_, pos $_;
4184 36 50       210 $here_script =~ s/.*?\n//oxm;
4185 36         554 }
4186 36         115 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4187             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4188             push @heredoc_delimiter, $delimiter;
4189 36         78 }
4190             else {
4191 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4192             }
4193             return $here_quote;
4194             }
4195              
4196 36         156 # <
4197 42         98 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4198 42         107 $slash = 'm//';
4199             my $here_quote = $1;
4200             my $delimiter = $2;
4201 42 50       80  
4202 42         113 # get here document
4203 42         397 if ($here_script eq '') {
4204             $here_script = CORE::substr $_, pos $_;
4205 42 50       329 $here_script =~ s/.*?\n//oxm;
4206 42         578 }
4207 42         147 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4208             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4209             push @heredoc_delimiter, $delimiter;
4210 42         125 }
4211             else {
4212 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4213             }
4214             return $here_quote;
4215             }
4216              
4217 42         177 # <<`HEREDOC`
4218 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4219 0         0 $slash = 'm//';
4220             my $here_quote = $1;
4221             my $delimiter = $2;
4222 0 0       0  
4223 0         0 # get here document
4224 0         0 if ($here_script eq '') {
4225             $here_script = CORE::substr $_, pos $_;
4226 0 0       0 $here_script =~ s/.*?\n//oxm;
4227 0         0 }
4228 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4229             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4230             push @heredoc_delimiter, $delimiter;
4231 0         0 }
4232             else {
4233 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4234             }
4235             return $here_quote;
4236             }
4237              
4238 0         0 # <<= <=> <= < operator
4239             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4240             return $1;
4241             }
4242              
4243 12         57 #
4244             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4245             return $1;
4246             }
4247              
4248             # --- glob
4249              
4250             # avoid "Error: Runtime exception" of perl version 5.005_03
4251 0         0  
4252             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4253             return 'Eusascii::glob("' . $1 . '")';
4254             }
4255 0         0  
4256             # __DATA__
4257             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4258 0         0  
4259             # __END__
4260             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4261              
4262             # \cD Control-D
4263              
4264             # P.68 2.6.8. Other Literal Tokens
4265             # in Chapter 2: Bits and Pieces
4266             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4267              
4268             # P.76 Other Literal Tokens
4269             # in Chapter 2: Bits and Pieces
4270 204         1461 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4271              
4272             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4273 0         0  
4274             # \cZ Control-Z
4275             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4276              
4277             # any operator before div
4278             elsif (/\G (
4279             -- | \+\+ |
4280 0         0 [\)\}\]]
  5017         9789  
4281              
4282             ) /oxgc) { $slash = 'div'; return $1; }
4283              
4284             # yada-yada or triple-dot operator
4285             elsif (/\G (
4286 5017         21677 \.\.\.
  7         13  
4287              
4288             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4289              
4290             # any operator before m//
4291              
4292             # //, //= (defined-or)
4293              
4294             # P.164 Logical Operators
4295             # in Chapter 10: More Control Structures
4296             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4297              
4298             # P.119 C-Style Logical (Short-Circuit) Operators
4299             # in Chapter 3: Unary and Binary Operators
4300             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4301              
4302             # (and so on)
4303              
4304             # ~~
4305              
4306             # P.221 The Smart Match Operator
4307             # in Chapter 15: Smart Matching and given-when
4308             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4309              
4310             # P.112 Smartmatch Operator
4311             # in Chapter 3: Unary and Binary Operators
4312             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4313              
4314             # (and so on)
4315              
4316             elsif (/\G ((?>
4317              
4318             !~~ | !~ | != | ! |
4319             %= | % |
4320             &&= | && | &= | &\.= | &\. | & |
4321             -= | -> | - |
4322             :(?>\s*)= |
4323             : |
4324             <<>> |
4325             <<= | <=> | <= | < |
4326             == | => | =~ | = |
4327             >>= | >> | >= | > |
4328             \*\*= | \*\* | \*= | \* |
4329             \+= | \+ |
4330             \.\. | \.= | \. |
4331             \/\/= | \/\/ |
4332             \/= | \/ |
4333             \? |
4334             \\ |
4335             \^= | \^\.= | \^\. | \^ |
4336             \b x= |
4337             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4338             ~~ | ~\. | ~ |
4339             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4340             \b(?: print )\b |
4341              
4342 7         23 [,;\(\{\[]
  8644         16367  
4343              
4344             )) /oxgc) { $slash = 'm//'; return $1; }
4345 8644         37135  
  15320         27927  
4346             # other any character
4347             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4348              
4349 15320         65554 # system error
4350             else {
4351             die __FILE__, ": Oops, this shouldn't happen!\n";
4352             }
4353             }
4354              
4355 0     1767 0 0 # escape US-ASCII string
4356 1767         4027 sub e_string {
4357             my($string) = @_;
4358 1767         2478 my $e_string = '';
4359              
4360             local $slash = 'm//';
4361              
4362             # P.1024 Appendix W.10 Multibyte Processing
4363             # of ISBN 1-56592-224-7 CJKV Information Processing
4364 1767         2542 # (and so on)
4365              
4366             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4367 1767 100 66     12997  
4368 1767 50       7230 # without { ... }
4369 1751         4002 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4370             if ($string !~ /<
4371             return $string;
4372             }
4373             }
4374 1751         4246  
4375 16 50       46 E_STRING_LOOP:
    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          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    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          
    50          
    100          
    50          
4376             while ($string !~ /\G \z/oxgc) {
4377             if (0) {
4378             }
4379 185         10459  
4380 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Eusascii::PREMATCH()]}
4381 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4382             $e_string .= q{Eusascii::PREMATCH()};
4383             $slash = 'div';
4384             }
4385              
4386 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Eusascii::MATCH()]}
4387 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4388             $e_string .= q{Eusascii::MATCH()};
4389             $slash = 'div';
4390             }
4391              
4392 0         0 # $', ${'} --> $', ${'}
4393 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4394             $e_string .= $1;
4395             $slash = 'div';
4396             }
4397              
4398 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Eusascii::POSTMATCH()]}
4399 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4400             $e_string .= q{Eusascii::POSTMATCH()};
4401             $slash = 'div';
4402             }
4403              
4404 0         0 # bareword
4405 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4406             $e_string .= $1;
4407             $slash = 'div';
4408             }
4409              
4410 0         0 # $0 --> $0
4411 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4412             $e_string .= $1;
4413             $slash = 'div';
4414 0         0 }
4415 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4416             $e_string .= $1;
4417             $slash = 'div';
4418             }
4419              
4420 0         0 # $$ --> $$
4421 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4422             $e_string .= $1;
4423             $slash = 'div';
4424             }
4425              
4426             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4427 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4428 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4429             $e_string .= e_capture($1);
4430             $slash = 'div';
4431 0         0 }
4432 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4433             $e_string .= e_capture($1);
4434             $slash = 'div';
4435             }
4436              
4437 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4438 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4439             $e_string .= e_capture($1.'->'.$2);
4440             $slash = 'div';
4441             }
4442              
4443 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4444 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4445             $e_string .= e_capture($1.'->'.$2);
4446             $slash = 'div';
4447             }
4448              
4449 0         0 # $$foo
4450 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4451             $e_string .= e_capture($1);
4452             $slash = 'div';
4453             }
4454              
4455 0         0 # ${ foo }
4456 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4457             $e_string .= '${' . $1 . '}';
4458             $slash = 'div';
4459             }
4460              
4461 0         0 # ${ ... }
4462 3         12 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4463             $e_string .= e_capture($1);
4464             $slash = 'div';
4465             }
4466              
4467             # variable or function
4468 3         16 # $ @ % & * $ #
4469 6         15 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) {
4470             $e_string .= $1;
4471             $slash = 'div';
4472             }
4473             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4474 6         16 # $ @ # \ ' " / ? ( ) [ ] < >
4475 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4476             $e_string .= $1;
4477             $slash = 'div';
4478             }
4479 0         0  
  0         0  
4480 0         0 # subroutines of package Eusascii
  0         0  
4481 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4482 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4483 0         0 elsif ($string =~ /\G \b USASCII::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4484 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4485 0         0 elsif ($string =~ /\G \b USASCII::eval \b /oxgc) { $e_string .= 'eval USASCII::escape'; $slash = 'm//'; }
  0         0  
4486 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4487 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Eusascii::chop'; $slash = 'm//'; }
  0         0  
4488 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4489 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4490 0         0 elsif ($string =~ /\G \b USASCII::index \b /oxgc) { $e_string .= 'USASCII::index'; $slash = 'm//'; }
  0         0  
4491 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Eusascii::index'; $slash = 'm//'; }
  0         0  
4492 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4493 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4494 0         0 elsif ($string =~ /\G \b USASCII::rindex \b /oxgc) { $e_string .= 'USASCII::rindex'; $slash = 'm//'; }
  0         0  
4495 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Eusascii::rindex'; $slash = 'm//'; }
  0         0  
4496 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::lc'; $slash = 'm//'; }
  0         0  
4497 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::lcfirst'; $slash = 'm//'; }
  0         0  
4498 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::uc'; $slash = 'm//'; }
  0         0  
4499             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::ucfirst'; $slash = 'm//'; }
4500             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::fc'; $slash = 'm//'; }
4501 0         0  
  0         0  
4502 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4503 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4504 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  
4505 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  
4506 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  
4507 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  
4508             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4509 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  
4510 0         0  
  0         0  
4511 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4512 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  
4513 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  
4514 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  
4515 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  
4516             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4517             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4518 0         0  
  0         0  
4519 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4520 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4521 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4522             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4523 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4524 0         0  
  0         0  
4525 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4526 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4527 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::chr'; $slash = 'm//'; }
  0         0  
4528 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4529 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4530 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::glob'; $slash = 'm//'; }
  0         0  
4531 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Eusascii::lc_'; $slash = 'm//'; }
  0         0  
4532 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Eusascii::lcfirst_'; $slash = 'm//'; }
  0         0  
4533 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Eusascii::uc_'; $slash = 'm//'; }
  0         0  
4534 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Eusascii::ucfirst_'; $slash = 'm//'; }
  0         0  
4535             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Eusascii::fc_'; $slash = 'm//'; }
4536 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4537 0         0  
  0         0  
4538 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4539 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4540 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Eusascii::chr_'; $slash = 'm//'; }
  0         0  
4541 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4542 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4543 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Eusascii::glob_'; $slash = 'm//'; }
  0         0  
4544             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4545             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4546 0         0 # split
4547             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4548 0         0 $slash = 'm//';
4549 0         0  
4550 0         0 my $e = '';
4551             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4552             $e .= $1;
4553             }
4554 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          
4555             # end of split
4556             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Eusascii::split' . $e; }
4557 0         0  
  0         0  
4558             # split scalar value
4559             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Eusascii::split' . $e . e_string($1); next E_STRING_LOOP; }
4560 0         0  
  0         0  
4561 0         0 # split literal space
  0         0  
4562 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4563 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4564 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4565 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4566 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4567 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4568 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4569 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4570 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4571 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4572 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4573 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4574             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {' '}; next E_STRING_LOOP; }
4575             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {" "}; next E_STRING_LOOP; }
4576              
4577 0 0       0 # split qq//
  0         0  
  0         0  
4578             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4579 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4580 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4581 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4582 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4583 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  
4584 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  
4585 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  
4586 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  
4587             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4588 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 * *
4589             }
4590             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4591             }
4592             }
4593              
4594 0 0       0 # split qr//
  0         0  
  0         0  
4595             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4596 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4597 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4598 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4599 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4600 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  
4601 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  
4602 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  
4603 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  
4604 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  
4605             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4606 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 * *
4607             }
4608             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4609             }
4610             }
4611              
4612 0 0       0 # split q//
  0         0  
  0         0  
4613             elsif ($string =~ /\G \b (q) \b /oxgc) {
4614 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4615 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4616 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4617 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4618 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  
4619 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  
4620 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  
4621 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  
4622             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4623 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 * *
4624             }
4625             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4626             }
4627             }
4628              
4629 0 0       0 # split m//
  0         0  
  0         0  
4630             elsif ($string =~ /\G \b (m) \b /oxgc) {
4631 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 # #
4632 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4633 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4634 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4635 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  
4636 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  
4637 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  
4638 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  
4639 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  
4640             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4641 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 * *
4642             }
4643             die __FILE__, ": Search pattern not terminated\n";
4644             }
4645             }
4646              
4647 0         0 # split ''
4648 0         0 elsif ($string =~ /\G (\') /oxgc) {
4649 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4650 0         0 while ($string !~ /\G \z/oxgc) {
4651 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4652 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4653             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4654 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4655             }
4656             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4657             }
4658              
4659 0         0 # split ""
4660 0         0 elsif ($string =~ /\G (\") /oxgc) {
4661 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4662 0         0 while ($string !~ /\G \z/oxgc) {
4663 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4664 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4665             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4666 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4667             }
4668             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4669             }
4670              
4671 0         0 # split //
4672 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4673 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4674 0         0 while ($string !~ /\G \z/oxgc) {
4675 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4676 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4677             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4678 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4679             }
4680             die __FILE__, ": Search pattern not terminated\n";
4681             }
4682             }
4683              
4684 0         0 # qq//
4685 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4686 0         0 my $ope = $1;
4687             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4688             $e_string .= e_qq($ope,$1,$3,$2);
4689 0         0 }
4690 0         0 else {
4691 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4692 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4693 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4694 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4695 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4696 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4697             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4698 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4699             }
4700             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4701             }
4702             }
4703              
4704 0         0 # qx//
4705 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4706 0         0 my $ope = $1;
4707             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4708             $e_string .= e_qq($ope,$1,$3,$2);
4709 0         0 }
4710 0         0 else {
4711 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4712 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4713 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4714 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4715 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4716 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4717 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4718             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4719 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4720             }
4721             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4722             }
4723             }
4724              
4725 0         0 # q//
4726 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4727 0         0 my $ope = $1;
4728             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4729             $e_string .= e_q($ope,$1,$3,$2);
4730 0         0 }
4731 0         0 else {
4732 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4733 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4734 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4735 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4736 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4737 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4738             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4739 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 * *
4740             }
4741             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4742             }
4743             }
4744 0         0  
4745             # ''
4746             elsif ($string =~ /\G (?
4747 0         0  
4748             # ""
4749             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4750 0         0  
4751             # ``
4752             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4753 0         0  
4754             # <<>> (a safer ARGV)
4755             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4756 0         0  
4757             # <<= <=> <= < operator
4758             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4759 0         0  
4760             #
4761             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4762              
4763 0         0 # --- glob
4764             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4765             $e_string .= 'Eusascii::glob("' . $1 . '")';
4766             }
4767              
4768 0         0 # << (bit shift) --- not here document
4769 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4770             $slash = 'm//';
4771             $e_string .= $1;
4772             }
4773              
4774 0         0 # <<~'HEREDOC'
4775 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4776 0         0 $slash = 'm//';
4777             my $here_quote = $1;
4778             my $delimiter = $2;
4779 0 0       0  
4780 0         0 # get here document
4781 0         0 if ($here_script eq '') {
4782             $here_script = CORE::substr $_, pos $_;
4783 0 0       0 $here_script =~ s/.*?\n//oxm;
4784 0         0 }
4785 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4786 0         0 my $heredoc = $1;
4787 0         0 my $indent = $2;
4788 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4789             push @heredoc, $heredoc . qq{\n$delimiter\n};
4790             push @heredoc_delimiter, qq{\\s*$delimiter};
4791 0         0 }
4792             else {
4793 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4794             }
4795             $e_string .= qq{<<'$delimiter'};
4796             }
4797              
4798 0         0 # <<~\HEREDOC
4799 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4800 0         0 $slash = 'm//';
4801             my $here_quote = $1;
4802             my $delimiter = $2;
4803 0 0       0  
4804 0         0 # get here document
4805 0         0 if ($here_script eq '') {
4806             $here_script = CORE::substr $_, pos $_;
4807 0 0       0 $here_script =~ s/.*?\n//oxm;
4808 0         0 }
4809 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4810 0         0 my $heredoc = $1;
4811 0         0 my $indent = $2;
4812 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4813             push @heredoc, $heredoc . qq{\n$delimiter\n};
4814             push @heredoc_delimiter, qq{\\s*$delimiter};
4815 0         0 }
4816             else {
4817 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4818             }
4819             $e_string .= qq{<<\\$delimiter};
4820             }
4821              
4822 0         0 # <<~"HEREDOC"
4823 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4824 0         0 $slash = 'm//';
4825             my $here_quote = $1;
4826             my $delimiter = $2;
4827 0 0       0  
4828 0         0 # get here document
4829 0         0 if ($here_script eq '') {
4830             $here_script = CORE::substr $_, pos $_;
4831 0 0       0 $here_script =~ s/.*?\n//oxm;
4832 0         0 }
4833 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4834 0         0 my $heredoc = $1;
4835 0         0 my $indent = $2;
4836 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4837             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4838             push @heredoc_delimiter, qq{\\s*$delimiter};
4839 0         0 }
4840             else {
4841 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4842             }
4843             $e_string .= qq{<<"$delimiter"};
4844             }
4845              
4846 0         0 # <<~HEREDOC
4847 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4848 0         0 $slash = 'm//';
4849             my $here_quote = $1;
4850             my $delimiter = $2;
4851 0 0       0  
4852 0         0 # get here document
4853 0         0 if ($here_script eq '') {
4854             $here_script = CORE::substr $_, pos $_;
4855 0 0       0 $here_script =~ s/.*?\n//oxm;
4856 0         0 }
4857 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4858 0         0 my $heredoc = $1;
4859 0         0 my $indent = $2;
4860 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4861             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4862             push @heredoc_delimiter, qq{\\s*$delimiter};
4863 0         0 }
4864             else {
4865 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4866             }
4867             $e_string .= qq{<<$delimiter};
4868             }
4869              
4870 0         0 # <<~`HEREDOC`
4871 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4872 0         0 $slash = 'm//';
4873             my $here_quote = $1;
4874             my $delimiter = $2;
4875 0 0       0  
4876 0         0 # get here document
4877 0         0 if ($here_script eq '') {
4878             $here_script = CORE::substr $_, pos $_;
4879 0 0       0 $here_script =~ s/.*?\n//oxm;
4880 0         0 }
4881 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4882 0         0 my $heredoc = $1;
4883 0         0 my $indent = $2;
4884 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4885             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4886             push @heredoc_delimiter, qq{\\s*$delimiter};
4887 0         0 }
4888             else {
4889 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4890             }
4891             $e_string .= qq{<<`$delimiter`};
4892             }
4893              
4894 0         0 # <<'HEREDOC'
4895 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4896 0         0 $slash = 'm//';
4897             my $here_quote = $1;
4898             my $delimiter = $2;
4899 0 0       0  
4900 0         0 # get here document
4901 0         0 if ($here_script eq '') {
4902             $here_script = CORE::substr $_, pos $_;
4903 0 0       0 $here_script =~ s/.*?\n//oxm;
4904 0         0 }
4905 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4906             push @heredoc, $1 . qq{\n$delimiter\n};
4907             push @heredoc_delimiter, $delimiter;
4908 0         0 }
4909             else {
4910 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4911             }
4912             $e_string .= $here_quote;
4913             }
4914              
4915 0         0 # <<\HEREDOC
4916 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4917 0         0 $slash = 'm//';
4918             my $here_quote = $1;
4919             my $delimiter = $2;
4920 0 0       0  
4921 0         0 # get here document
4922 0         0 if ($here_script eq '') {
4923             $here_script = CORE::substr $_, pos $_;
4924 0 0       0 $here_script =~ s/.*?\n//oxm;
4925 0         0 }
4926 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4927             push @heredoc, $1 . qq{\n$delimiter\n};
4928             push @heredoc_delimiter, $delimiter;
4929 0         0 }
4930             else {
4931 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4932             }
4933             $e_string .= $here_quote;
4934             }
4935              
4936 0         0 # <<"HEREDOC"
4937 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4938 0         0 $slash = 'm//';
4939             my $here_quote = $1;
4940             my $delimiter = $2;
4941 0 0       0  
4942 0         0 # get here document
4943 0         0 if ($here_script eq '') {
4944             $here_script = CORE::substr $_, pos $_;
4945 0 0       0 $here_script =~ s/.*?\n//oxm;
4946 0         0 }
4947 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4948             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4949             push @heredoc_delimiter, $delimiter;
4950 0         0 }
4951             else {
4952 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4953             }
4954             $e_string .= $here_quote;
4955             }
4956              
4957 0         0 # <
4958 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4959 0         0 $slash = 'm//';
4960             my $here_quote = $1;
4961             my $delimiter = $2;
4962 0 0       0  
4963 0         0 # get here document
4964 0         0 if ($here_script eq '') {
4965             $here_script = CORE::substr $_, pos $_;
4966 0 0       0 $here_script =~ s/.*?\n//oxm;
4967 0         0 }
4968 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4969             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4970             push @heredoc_delimiter, $delimiter;
4971 0         0 }
4972             else {
4973 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4974             }
4975             $e_string .= $here_quote;
4976             }
4977              
4978 0         0 # <<`HEREDOC`
4979 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4980 0         0 $slash = 'm//';
4981             my $here_quote = $1;
4982             my $delimiter = $2;
4983 0 0       0  
4984 0         0 # get here document
4985 0         0 if ($here_script eq '') {
4986             $here_script = CORE::substr $_, pos $_;
4987 0 0       0 $here_script =~ s/.*?\n//oxm;
4988 0         0 }
4989 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4990             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4991             push @heredoc_delimiter, $delimiter;
4992 0         0 }
4993             else {
4994 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4995             }
4996             $e_string .= $here_quote;
4997             }
4998              
4999             # any operator before div
5000             elsif ($string =~ /\G (
5001             -- | \+\+ |
5002 0         0 [\)\}\]]
  17         30  
5003              
5004             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5005              
5006             # yada-yada or triple-dot operator
5007             elsif ($string =~ /\G (
5008 17         74 \.\.\.
  0         0  
5009              
5010             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5011              
5012             # any operator before m//
5013             elsif ($string =~ /\G ((?>
5014              
5015             !~~ | !~ | != | ! |
5016             %= | % |
5017             &&= | && | &= | &\.= | &\. | & |
5018             -= | -> | - |
5019             :(?>\s*)= |
5020             : |
5021             <<>> |
5022             <<= | <=> | <= | < |
5023             == | => | =~ | = |
5024             >>= | >> | >= | > |
5025             \*\*= | \*\* | \*= | \* |
5026             \+= | \+ |
5027             \.\. | \.= | \. |
5028             \/\/= | \/\/ |
5029             \/= | \/ |
5030             \? |
5031             \\ |
5032             \^= | \^\.= | \^\. | \^ |
5033             \b x= |
5034             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5035             ~~ | ~\. | ~ |
5036             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5037             \b(?: print )\b |
5038              
5039 0         0 [,;\(\{\[]
  30         59  
5040              
5041             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5042 30         94  
5043             # other any character
5044             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5045              
5046 129         371 # system error
5047             else {
5048             die __FILE__, ": Oops, this shouldn't happen!\n";
5049             }
5050 0         0 }
5051              
5052             return $e_string;
5053             }
5054              
5055             #
5056             # character class
5057 16     1879 0 68 #
5058             sub character_class {
5059 1879 100       3171 my($char,$modifier) = @_;
5060 1879 100       2942  
5061 52         98 if ($char eq '.') {
5062             if ($modifier =~ /s/) {
5063             return '${Eusascii::dot_s}';
5064 17         36 }
5065             else {
5066             return '${Eusascii::dot}';
5067             }
5068 35         74 }
5069             else {
5070             return Eusascii::classic_character_class($char);
5071             }
5072             }
5073              
5074             #
5075             # escape capture ($1, $2, $3, ...)
5076             #
5077 1827     212 0 3186 sub e_capture {
5078              
5079             return join '', '${', $_[0], '}';
5080             }
5081              
5082             #
5083             # escape transliteration (tr/// or y///)
5084 212     3 0 734 #
5085 3         20 sub e_tr {
5086 3   50     7 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5087             my $e_tr = '';
5088 3         7 $modifier ||= '';
5089              
5090             $slash = 'div';
5091 3         6  
5092             # quote character class 1
5093             $charclass = q_tr($charclass);
5094 3         5  
5095             # quote character class 2
5096             $charclass2 = q_tr($charclass2);
5097 3 50       7  
5098 3 0       10 # /b /B modifier
5099 0         0 if ($modifier =~ tr/bB//d) {
5100             if ($variable eq '') {
5101             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5102 0         0 }
5103             else {
5104             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5105             }
5106 0 100       0 }
5107 3         10 else {
5108             if ($variable eq '') {
5109             $e_tr = qq{Eusascii::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5110 2         9 }
5111             else {
5112             $e_tr = qq{Eusascii::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5113             }
5114             }
5115 1         4  
5116 3         10 # clear tr/// variable
5117             $tr_variable = '';
5118 3         6 $bind_operator = '';
5119              
5120             return $e_tr;
5121             }
5122              
5123             #
5124             # quote for escape transliteration (tr/// or y///)
5125 3     6 0 17 #
5126             sub q_tr {
5127             my($charclass) = @_;
5128 6 50       11  
    0          
    0          
    0          
    0          
    0          
5129 6         12 # quote character class
5130             if ($charclass !~ /'/oxms) {
5131             return e_q('', "'", "'", $charclass); # --> q' '
5132 6         10 }
5133             elsif ($charclass !~ /\//oxms) {
5134             return e_q('q', '/', '/', $charclass); # --> q/ /
5135 0         0 }
5136             elsif ($charclass !~ /\#/oxms) {
5137             return e_q('q', '#', '#', $charclass); # --> q# #
5138 0         0 }
5139             elsif ($charclass !~ /[\<\>]/oxms) {
5140             return e_q('q', '<', '>', $charclass); # --> q< >
5141 0         0 }
5142             elsif ($charclass !~ /[\(\)]/oxms) {
5143             return e_q('q', '(', ')', $charclass); # --> q( )
5144 0         0 }
5145             elsif ($charclass !~ /[\{\}]/oxms) {
5146             return e_q('q', '{', '}', $charclass); # --> q{ }
5147 0         0 }
5148 0 0       0 else {
5149 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5150             if ($charclass !~ /\Q$char\E/xms) {
5151             return e_q('q', $char, $char, $charclass);
5152             }
5153             }
5154 0         0 }
5155              
5156             return e_q('q', '{', '}', $charclass);
5157             }
5158              
5159             #
5160             # escape q string (q//, '')
5161 0     1264 0 0 #
5162             sub e_q {
5163 1264         2927 my($ope,$delimiter,$end_delimiter,$string) = @_;
5164              
5165 1264         1828 $slash = 'div';
5166              
5167             return join '', $ope, $delimiter, $string, $end_delimiter;
5168             }
5169              
5170             #
5171             # escape qq string (qq//, "", qx//, ``)
5172 1264     3770 0 6116 #
5173             sub e_qq {
5174 3770         8002 my($ope,$delimiter,$end_delimiter,$string) = @_;
5175              
5176 3770         4930 $slash = 'div';
5177 3770         4348  
5178             my $left_e = 0;
5179             my $right_e = 0;
5180 3770         4080  
5181             # split regexp
5182             my @char = $string =~ /\G((?>
5183             [^\\\$] |
5184             \\x\{ (?>[0-9A-Fa-f]+) \} |
5185             \\o\{ (?>[0-7]+) \} |
5186             \\N\{ (?>[^0-9\}][^\}]*) \} |
5187             \\ $q_char |
5188             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5189             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5190             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5191             \$ (?>\s* [0-9]+) |
5192             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5193             \$ \$ (?![\w\{]) |
5194             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5195             $q_char
5196 3770         128987 ))/oxmsg;
5197              
5198             for (my $i=0; $i <= $#char; $i++) {
5199 3770 50 33     11465  
    50 33        
    100          
    100          
    50          
5200 114739         350696 # "\L\u" --> "\u\L"
5201             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5202             @char[$i,$i+1] = @char[$i+1,$i];
5203             }
5204              
5205 0         0 # "\U\l" --> "\l\U"
5206             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5207             @char[$i,$i+1] = @char[$i+1,$i];
5208             }
5209              
5210 0         0 # octal escape sequence
5211             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5212             $char[$i] = Eusascii::octchr($1);
5213             }
5214              
5215 1         3 # hexadecimal escape sequence
5216             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5217             $char[$i] = Eusascii::hexchr($1);
5218             }
5219              
5220 1         4 # \N{CHARNAME} --> N{CHARNAME}
5221             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5222             $char[$i] = $1;
5223 0 100       0 }
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5224              
5225             if (0) {
5226             }
5227              
5228             # \F
5229             #
5230             # P.69 Table 2-6. Translation escapes
5231             # in Chapter 2: Bits and Pieces
5232             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5233             # (and so on)
5234 114739         863065  
5235 0 50       0 # \u \l \U \L \F \Q \E
5236 484         1070 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5237             if ($right_e < $left_e) {
5238             $char[$i] = '\\' . $char[$i];
5239             }
5240             }
5241             elsif ($char[$i] eq '\u') {
5242              
5243             # "STRING @{[ LIST EXPR ]} MORE STRING"
5244              
5245             # P.257 Other Tricks You Can Do with Hard References
5246             # in Chapter 8: References
5247             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5248              
5249             # P.353 Other Tricks You Can Do with Hard References
5250             # in Chapter 8: References
5251             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5252              
5253 0         0 # (and so on)
5254 0         0  
5255             $char[$i] = '@{[Eusascii::ucfirst qq<';
5256             $left_e++;
5257 0         0 }
5258 0         0 elsif ($char[$i] eq '\l') {
5259             $char[$i] = '@{[Eusascii::lcfirst qq<';
5260             $left_e++;
5261 0         0 }
5262 0         0 elsif ($char[$i] eq '\U') {
5263             $char[$i] = '@{[Eusascii::uc qq<';
5264             $left_e++;
5265 0         0 }
5266 0         0 elsif ($char[$i] eq '\L') {
5267             $char[$i] = '@{[Eusascii::lc qq<';
5268             $left_e++;
5269 0         0 }
5270 8         12 elsif ($char[$i] eq '\F') {
5271             $char[$i] = '@{[Eusascii::fc qq<';
5272             $left_e++;
5273 8         13 }
5274 0         0 elsif ($char[$i] eq '\Q') {
5275             $char[$i] = '@{[CORE::quotemeta qq<';
5276             $left_e++;
5277 0 50       0 }
5278 8         12 elsif ($char[$i] eq '\E') {
5279 8         10 if ($right_e < $left_e) {
5280             $char[$i] = '>]}';
5281             $right_e++;
5282 8         14 }
5283             else {
5284             $char[$i] = '';
5285             }
5286 0         0 }
5287 0 0       0 elsif ($char[$i] eq '\Q') {
5288 0         0 while (1) {
5289             if (++$i > $#char) {
5290 0 0       0 last;
5291 0         0 }
5292             if ($char[$i] eq '\E') {
5293             last;
5294             }
5295             }
5296             }
5297             elsif ($char[$i] eq '\E') {
5298             }
5299              
5300             # $0 --> $0
5301             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5302             }
5303             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5304             }
5305              
5306             # $$ --> $$
5307             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5308             }
5309              
5310             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5311 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5312             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5313             $char[$i] = e_capture($1);
5314 205         377 }
5315             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5316             $char[$i] = e_capture($1);
5317             }
5318              
5319 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5320             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5321             $char[$i] = e_capture($1.'->'.$2);
5322             }
5323              
5324 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5325             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5326             $char[$i] = e_capture($1.'->'.$2);
5327             }
5328              
5329 0         0 # $$foo
5330             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5331             $char[$i] = e_capture($1);
5332             }
5333              
5334 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
5335             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5336             $char[$i] = '@{[Eusascii::PREMATCH()]}';
5337             }
5338              
5339 44         111 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
5340             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5341             $char[$i] = '@{[Eusascii::MATCH()]}';
5342             }
5343              
5344 45         134 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
5345             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5346             $char[$i] = '@{[Eusascii::POSTMATCH()]}';
5347             }
5348              
5349             # ${ foo } --> ${ foo }
5350             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5351             }
5352              
5353 33         99 # ${ ... }
5354             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5355             $char[$i] = e_capture($1);
5356             }
5357             }
5358 0 50       0  
5359 3770         6852 # return string
5360             if ($left_e > $right_e) {
5361 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5362             }
5363             return join '', $ope, $delimiter, @char, $end_delimiter;
5364             }
5365              
5366             #
5367             # escape qw string (qw//)
5368 3770     14 0 29595 #
5369             sub e_qw {
5370 14         65 my($ope,$delimiter,$end_delimiter,$string) = @_;
5371              
5372             $slash = 'div';
5373 14         28  
  14         161  
5374 381 50       589 # choice again delimiter
    0          
    0          
    0          
    0          
5375 14         103 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5376             if (not $octet{$end_delimiter}) {
5377             return join '', $ope, $delimiter, $string, $end_delimiter;
5378 14         126 }
5379             elsif (not $octet{')'}) {
5380             return join '', $ope, '(', $string, ')';
5381 0         0 }
5382             elsif (not $octet{'}'}) {
5383             return join '', $ope, '{', $string, '}';
5384 0         0 }
5385             elsif (not $octet{']'}) {
5386             return join '', $ope, '[', $string, ']';
5387 0         0 }
5388             elsif (not $octet{'>'}) {
5389             return join '', $ope, '<', $string, '>';
5390 0         0 }
5391 0 0       0 else {
5392 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5393             if (not $octet{$char}) {
5394             return join '', $ope, $char, $string, $char;
5395             }
5396             }
5397             }
5398 0         0  
5399 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5400 0         0 my @string = CORE::split(/\s+/, $string);
5401 0         0 for my $string (@string) {
5402 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5403 0         0 for my $octet (@octet) {
5404             if ($octet =~ /\A (['\\]) \z/oxms) {
5405             $octet = '\\' . $1;
5406 0         0 }
5407             }
5408 0         0 $string = join '', @octet;
  0         0  
5409             }
5410             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5411             }
5412              
5413             #
5414             # escape here document (<<"HEREDOC", <
5415 0     93 0 0 #
5416             sub e_heredoc {
5417 93         243 my($string) = @_;
5418              
5419 93         154 $slash = 'm//';
5420              
5421 93         300 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5422 93         141  
5423             my $left_e = 0;
5424             my $right_e = 0;
5425 93         114  
5426             # split regexp
5427             my @char = $string =~ /\G((?>
5428             [^\\\$] |
5429             \\x\{ (?>[0-9A-Fa-f]+) \} |
5430             \\o\{ (?>[0-7]+) \} |
5431             \\N\{ (?>[^0-9\}][^\}]*) \} |
5432             \\ $q_char |
5433             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5434             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5435             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5436             \$ (?>\s* [0-9]+) |
5437             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5438             \$ \$ (?![\w\{]) |
5439             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5440             $q_char
5441 93         9543 ))/oxmsg;
5442              
5443             for (my $i=0; $i <= $#char; $i++) {
5444 93 50 33     413  
    50 33        
    100          
    100          
    50          
5445 5515         16106 # "\L\u" --> "\u\L"
5446             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5447             @char[$i,$i+1] = @char[$i+1,$i];
5448             }
5449              
5450 0         0 # "\U\l" --> "\l\U"
5451             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5452             @char[$i,$i+1] = @char[$i+1,$i];
5453             }
5454              
5455 0         0 # octal escape sequence
5456             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5457             $char[$i] = Eusascii::octchr($1);
5458             }
5459              
5460 1         2 # hexadecimal escape sequence
5461             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5462             $char[$i] = Eusascii::hexchr($1);
5463             }
5464              
5465 1         6 # \N{CHARNAME} --> N{CHARNAME}
5466             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5467             $char[$i] = $1;
5468 0 50       0 }
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5469              
5470             if (0) {
5471             }
5472 5515         40263  
5473 0 0       0 # \u \l \U \L \F \Q \E
5474 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5475             if ($right_e < $left_e) {
5476             $char[$i] = '\\' . $char[$i];
5477             }
5478 0         0 }
5479 0         0 elsif ($char[$i] eq '\u') {
5480             $char[$i] = '@{[Eusascii::ucfirst qq<';
5481             $left_e++;
5482 0         0 }
5483 0         0 elsif ($char[$i] eq '\l') {
5484             $char[$i] = '@{[Eusascii::lcfirst qq<';
5485             $left_e++;
5486 0         0 }
5487 0         0 elsif ($char[$i] eq '\U') {
5488             $char[$i] = '@{[Eusascii::uc qq<';
5489             $left_e++;
5490 0         0 }
5491 0         0 elsif ($char[$i] eq '\L') {
5492             $char[$i] = '@{[Eusascii::lc qq<';
5493             $left_e++;
5494 0         0 }
5495 0         0 elsif ($char[$i] eq '\F') {
5496             $char[$i] = '@{[Eusascii::fc qq<';
5497             $left_e++;
5498 0         0 }
5499 0         0 elsif ($char[$i] eq '\Q') {
5500             $char[$i] = '@{[CORE::quotemeta qq<';
5501             $left_e++;
5502 0 0       0 }
5503 0         0 elsif ($char[$i] eq '\E') {
5504 0         0 if ($right_e < $left_e) {
5505             $char[$i] = '>]}';
5506             $right_e++;
5507 0         0 }
5508             else {
5509             $char[$i] = '';
5510             }
5511 0         0 }
5512 0 0       0 elsif ($char[$i] eq '\Q') {
5513 0         0 while (1) {
5514             if (++$i > $#char) {
5515 0 0       0 last;
5516 0         0 }
5517             if ($char[$i] eq '\E') {
5518             last;
5519             }
5520             }
5521             }
5522             elsif ($char[$i] eq '\E') {
5523             }
5524              
5525             # $0 --> $0
5526             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5527             }
5528             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5529             }
5530              
5531             # $$ --> $$
5532             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5533             }
5534              
5535             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5536 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5537             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5538             $char[$i] = e_capture($1);
5539 0         0 }
5540             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5541             $char[$i] = e_capture($1);
5542             }
5543              
5544 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5545             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5546             $char[$i] = e_capture($1.'->'.$2);
5547             }
5548              
5549 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5550             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5551             $char[$i] = e_capture($1.'->'.$2);
5552             }
5553              
5554 0         0 # $$foo
5555             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5556             $char[$i] = e_capture($1);
5557             }
5558              
5559 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
5560             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5561             $char[$i] = '@{[Eusascii::PREMATCH()]}';
5562             }
5563              
5564 8         43 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
5565             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5566             $char[$i] = '@{[Eusascii::MATCH()]}';
5567             }
5568              
5569 8         44 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
5570             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5571             $char[$i] = '@{[Eusascii::POSTMATCH()]}';
5572             }
5573              
5574             # ${ foo } --> ${ foo }
5575             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5576             }
5577              
5578 6         35 # ${ ... }
5579             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5580             $char[$i] = e_capture($1);
5581             }
5582             }
5583 0 50       0  
5584 93         191 # return string
5585             if ($left_e > $right_e) {
5586 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5587             }
5588             return join '', @char;
5589             }
5590              
5591             #
5592             # escape regexp (m//, qr//)
5593 93     624 0 864 #
5594 624   100     2516 sub e_qr {
5595             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5596 624         2446 $modifier ||= '';
5597 624 50       1044  
5598 624         1341 $modifier =~ tr/p//d;
5599 0         0 if ($modifier =~ /([adlu])/oxms) {
5600 0 0       0 my $line = 0;
5601 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5602 0         0 if ($filename ne __FILE__) {
5603             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5604             last;
5605 0         0 }
5606             }
5607             die qq{Unsupported modifier "$1" used at line $line.\n};
5608 0         0 }
5609              
5610             $slash = 'div';
5611 624 100       943  
    100          
5612 624         1683 # literal null string pattern
5613 8         11 if ($string eq '') {
5614 8         13 $modifier =~ tr/bB//d;
5615             $modifier =~ tr/i//d;
5616             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5617             }
5618              
5619             # /b /B modifier
5620             elsif ($modifier =~ tr/bB//d) {
5621 8 50       37  
5622 2         7 # choice again delimiter
5623 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5624 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5625 0         0 my %octet = map {$_ => 1} @char;
5626 0         0 if (not $octet{')'}) {
5627             $delimiter = '(';
5628             $end_delimiter = ')';
5629 0         0 }
5630 0         0 elsif (not $octet{'}'}) {
5631             $delimiter = '{';
5632             $end_delimiter = '}';
5633 0         0 }
5634 0         0 elsif (not $octet{']'}) {
5635             $delimiter = '[';
5636             $end_delimiter = ']';
5637 0         0 }
5638 0         0 elsif (not $octet{'>'}) {
5639             $delimiter = '<';
5640             $end_delimiter = '>';
5641 0         0 }
5642 0 0       0 else {
5643 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5644 0         0 if (not $octet{$char}) {
5645 0         0 $delimiter = $char;
5646             $end_delimiter = $char;
5647             last;
5648             }
5649             }
5650             }
5651 0 50 33     0 }
5652 2         14  
5653             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5654             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5655 0         0 }
5656             else {
5657             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5658             }
5659 2 100       14 }
5660 614         1311  
5661             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5662             my $metachar = qr/[\@\\|[\]{^]/oxms;
5663 614         2049  
5664             # split regexp
5665             my @char = $string =~ /\G((?>
5666             [^\\\$\@\[\(] |
5667             \\x (?>[0-9A-Fa-f]{1,2}) |
5668             \\ (?>[0-7]{2,3}) |
5669             \\c [\x40-\x5F] |
5670             \\x\{ (?>[0-9A-Fa-f]+) \} |
5671             \\o\{ (?>[0-7]+) \} |
5672             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5673             \\ $q_char |
5674             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5675             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5676             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5677             [\$\@] $qq_variable |
5678             \$ (?>\s* [0-9]+) |
5679             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5680             \$ \$ (?![\w\{]) |
5681             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5682             \[\^ |
5683             \[\: (?>[a-z]+) :\] |
5684             \[\:\^ (?>[a-z]+) :\] |
5685             \(\? |
5686             $q_char
5687             ))/oxmsg;
5688 614 50       60343  
5689 614         2498 # choice again delimiter
  0         0  
5690 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5691 0         0 my %octet = map {$_ => 1} @char;
5692 0         0 if (not $octet{')'}) {
5693             $delimiter = '(';
5694             $end_delimiter = ')';
5695 0         0 }
5696 0         0 elsif (not $octet{'}'}) {
5697             $delimiter = '{';
5698             $end_delimiter = '}';
5699 0         0 }
5700 0         0 elsif (not $octet{']'}) {
5701             $delimiter = '[';
5702             $end_delimiter = ']';
5703 0         0 }
5704 0         0 elsif (not $octet{'>'}) {
5705             $delimiter = '<';
5706             $end_delimiter = '>';
5707 0         0 }
5708 0 0       0 else {
5709 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5710 0         0 if (not $octet{$char}) {
5711 0         0 $delimiter = $char;
5712             $end_delimiter = $char;
5713             last;
5714             }
5715             }
5716             }
5717 0         0 }
5718 614         940  
5719 614         837 my $left_e = 0;
5720             my $right_e = 0;
5721             for (my $i=0; $i <= $#char; $i++) {
5722 614 50 66     1424  
    50 66        
    100          
    100          
    100          
    100          
5723 1820         8961 # "\L\u" --> "\u\L"
5724             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5725             @char[$i,$i+1] = @char[$i+1,$i];
5726             }
5727              
5728 0         0 # "\U\l" --> "\l\U"
5729             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5730             @char[$i,$i+1] = @char[$i+1,$i];
5731             }
5732              
5733 0         0 # octal escape sequence
5734             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5735             $char[$i] = Eusascii::octchr($1);
5736             }
5737              
5738 1         3 # hexadecimal escape sequence
5739             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5740             $char[$i] = Eusascii::hexchr($1);
5741             }
5742              
5743             # \b{...} --> b\{...}
5744             # \B{...} --> B\{...}
5745             # \N{CHARNAME} --> N\{CHARNAME}
5746             # \p{PROPERTY} --> p\{PROPERTY}
5747 1         3 # \P{PROPERTY} --> P\{PROPERTY}
5748             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5749             $char[$i] = $1 . '\\' . $2;
5750             }
5751              
5752 6         22 # \p, \P, \X --> p, P, X
5753             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5754             $char[$i] = $1;
5755 4 100 100     11 }
    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          
5756              
5757             if (0) {
5758             }
5759 1820         5039  
5760 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5761 6         76 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5762             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)) {
5763             $char[$i] .= join '', splice @char, $i+1, 3;
5764 0         0 }
5765             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)) {
5766             $char[$i] .= join '', splice @char, $i+1, 2;
5767 0         0 }
5768             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)) {
5769             $char[$i] .= join '', splice @char, $i+1, 1;
5770             }
5771             }
5772              
5773 0         0 # open character class [...]
5774             elsif ($char[$i] eq '[') {
5775             my $left = $i;
5776              
5777             # [] make die "Unmatched [] in regexp ...\n"
5778 316 100       436 # (and so on)
5779 316         747  
5780             if ($char[$i+1] eq ']') {
5781             $i++;
5782 3         5 }
5783 316 50       390  
5784 1343         2106 while (1) {
5785             if (++$i > $#char) {
5786 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5787 1343         2228 }
5788             if ($char[$i] eq ']') {
5789             my $right = $i;
5790 316 100       428  
5791 316         1516 # [...]
  30         60  
5792             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5793             splice @char, $left, $right-$left+1, sprintf(q{@{[Eusascii::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5794 90         153 }
5795             else {
5796             splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
5797 286         980 }
5798 316         606  
5799             $i = $left;
5800             last;
5801             }
5802             }
5803             }
5804              
5805 316         771 # open character class [^...]
5806             elsif ($char[$i] eq '[^') {
5807             my $left = $i;
5808              
5809             # [^] make die "Unmatched [] in regexp ...\n"
5810 74 100       104 # (and so on)
5811 74         179  
5812             if ($char[$i+1] eq ']') {
5813             $i++;
5814 4         6 }
5815 74 50       90  
5816 272         386 while (1) {
5817             if (++$i > $#char) {
5818 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5819 272         416 }
5820             if ($char[$i] eq ']') {
5821             my $right = $i;
5822 74 100       108  
5823 74         354 # [^...]
  30         59  
5824             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5825             splice @char, $left, $right-$left+1, sprintf(q{@{[Eusascii::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5826 90         133 }
5827             else {
5828             splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5829 44         180 }
5830 74         133  
5831             $i = $left;
5832             last;
5833             }
5834             }
5835             }
5836              
5837 74         199 # rewrite character class or escape character
5838             elsif (my $char = character_class($char[$i],$modifier)) {
5839             $char[$i] = $char;
5840             }
5841              
5842 139 50       340 # /i modifier
5843 20         30 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
5844             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
5845             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
5846 20         42 }
5847             else {
5848             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
5849             }
5850             }
5851              
5852 0 50       0 # \u \l \U \L \F \Q \E
5853 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5854             if ($right_e < $left_e) {
5855             $char[$i] = '\\' . $char[$i];
5856             }
5857 0         0 }
5858 0         0 elsif ($char[$i] eq '\u') {
5859             $char[$i] = '@{[Eusascii::ucfirst qq<';
5860             $left_e++;
5861 0         0 }
5862 0         0 elsif ($char[$i] eq '\l') {
5863             $char[$i] = '@{[Eusascii::lcfirst qq<';
5864             $left_e++;
5865 0         0 }
5866 1         3 elsif ($char[$i] eq '\U') {
5867             $char[$i] = '@{[Eusascii::uc qq<';
5868             $left_e++;
5869 1         4 }
5870 1         2 elsif ($char[$i] eq '\L') {
5871             $char[$i] = '@{[Eusascii::lc qq<';
5872             $left_e++;
5873 1         4 }
5874 6         11 elsif ($char[$i] eq '\F') {
5875             $char[$i] = '@{[Eusascii::fc qq<';
5876             $left_e++;
5877 6         14 }
5878 1         3 elsif ($char[$i] eq '\Q') {
5879             $char[$i] = '@{[CORE::quotemeta qq<';
5880             $left_e++;
5881 1 50       3 }
5882 9         19 elsif ($char[$i] eq '\E') {
5883 9         13 if ($right_e < $left_e) {
5884             $char[$i] = '>]}';
5885             $right_e++;
5886 9         19 }
5887             else {
5888             $char[$i] = '';
5889             }
5890 0         0 }
5891 0 0       0 elsif ($char[$i] eq '\Q') {
5892 0         0 while (1) {
5893             if (++$i > $#char) {
5894 0 0       0 last;
5895 0         0 }
5896             if ($char[$i] eq '\E') {
5897             last;
5898             }
5899             }
5900             }
5901             elsif ($char[$i] eq '\E') {
5902             }
5903              
5904 0 0       0 # $0 --> $0
5905 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5906             if ($ignorecase) {
5907             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5908             }
5909 0 0       0 }
5910 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5911             if ($ignorecase) {
5912             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5913             }
5914             }
5915              
5916             # $$ --> $$
5917             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5918             }
5919              
5920             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5921 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5922 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5923 0         0 $char[$i] = e_capture($1);
5924             if ($ignorecase) {
5925             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5926             }
5927 0         0 }
5928 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5929 0         0 $char[$i] = e_capture($1);
5930             if ($ignorecase) {
5931             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5932             }
5933             }
5934              
5935 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5936 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) {
5937 0         0 $char[$i] = e_capture($1.'->'.$2);
5938             if ($ignorecase) {
5939             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5940             }
5941             }
5942              
5943 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5944 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) {
5945 0         0 $char[$i] = e_capture($1.'->'.$2);
5946             if ($ignorecase) {
5947             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5948             }
5949             }
5950              
5951 0         0 # $$foo
5952 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5953 0         0 $char[$i] = e_capture($1);
5954             if ($ignorecase) {
5955             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5956             }
5957             }
5958              
5959 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
5960 8         21 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5961             if ($ignorecase) {
5962             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::PREMATCH())]}';
5963 0         0 }
5964             else {
5965             $char[$i] = '@{[Eusascii::PREMATCH()]}';
5966             }
5967             }
5968              
5969 8 50       23 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
5970 8         26 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5971             if ($ignorecase) {
5972             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::MATCH())]}';
5973 0         0 }
5974             else {
5975             $char[$i] = '@{[Eusascii::MATCH()]}';
5976             }
5977             }
5978              
5979 8 50       23 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
5980 6         19 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5981             if ($ignorecase) {
5982             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::POSTMATCH())]}';
5983 0         0 }
5984             else {
5985             $char[$i] = '@{[Eusascii::POSTMATCH()]}';
5986             }
5987             }
5988              
5989 6 0       19 # ${ foo }
5990 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) {
5991             if ($ignorecase) {
5992             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5993             }
5994             }
5995              
5996 0         0 # ${ ... }
5997 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5998 0         0 $char[$i] = e_capture($1);
5999             if ($ignorecase) {
6000             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6001             }
6002             }
6003              
6004 0         0 # $scalar or @array
6005 5 100       14 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6006 5         16 $char[$i] = e_string($char[$i]);
6007             if ($ignorecase) {
6008             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6009             }
6010             }
6011              
6012 3 100 33     11 # quote character before ? + * {
    50          
6013             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6014             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6015 138         1024 }
6016 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6017 0         0 my $char = $char[$i-1];
6018             if ($char[$i] eq '{') {
6019             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6020 0         0 }
6021             else {
6022             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6023             }
6024 0         0 }
6025             else {
6026             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6027             }
6028             }
6029             }
6030 127         515  
6031 614 50       1170 # make regexp string
6032 614 0 0     1288 $modifier =~ tr/i//d;
6033 0         0 if ($left_e > $right_e) {
6034             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6035             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6036 0         0 }
6037             else {
6038             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6039 0 50 33     0 }
6040 614         3097 }
6041             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6042             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6043 0         0 }
6044             else {
6045             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6046             }
6047             }
6048              
6049             #
6050             # double quote stuff
6051 614     180 0 4921 #
6052             sub qq_stuff {
6053             my($delimiter,$end_delimiter,$stuff) = @_;
6054 180 100       267  
6055 180         345 # scalar variable or array variable
6056             if ($stuff =~ /\A [\$\@] /oxms) {
6057             return $stuff;
6058             }
6059 100         328  
  80         188  
6060 80         204 # quote by delimiter
6061 80 50       187 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6062 80 50       126 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6063 80 50       118 next if $char eq $delimiter;
6064 80         134 next if $char eq $end_delimiter;
6065             if (not $octet{$char}) {
6066             return join '', 'qq', $char, $stuff, $char;
6067 80         282 }
6068             }
6069             return join '', 'qq', '<', $stuff, '>';
6070             }
6071              
6072             #
6073             # escape regexp (m'', qr'', and m''b, qr''b)
6074 0     10 0 0 #
6075 10   50     42 sub e_qr_q {
6076             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6077 10         56 $modifier ||= '';
6078 10 50       17  
6079 10         21 $modifier =~ tr/p//d;
6080 0         0 if ($modifier =~ /([adlu])/oxms) {
6081 0 0       0 my $line = 0;
6082 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6083 0         0 if ($filename ne __FILE__) {
6084             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6085             last;
6086 0         0 }
6087             }
6088             die qq{Unsupported modifier "$1" used at line $line.\n};
6089 0         0 }
6090              
6091             $slash = 'div';
6092 10 100       13  
    50          
6093 10         25 # literal null string pattern
6094 8         11 if ($string eq '') {
6095 8         9 $modifier =~ tr/bB//d;
6096             $modifier =~ tr/i//d;
6097             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6098             }
6099              
6100 8         37 # with /b /B modifier
6101             elsif ($modifier =~ tr/bB//d) {
6102             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6103             }
6104              
6105 0         0 # without /b /B modifier
6106             else {
6107             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6108             }
6109             }
6110              
6111             #
6112             # escape regexp (m'', qr'')
6113 2     2 0 8 #
6114             sub e_qr_qt {
6115 2 50       7 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6116              
6117             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6118 2         6  
6119             # split regexp
6120             my @char = $string =~ /\G((?>
6121             [^\\\[\$\@\/] |
6122             [\x00-\xFF] |
6123             \[\^ |
6124             \[\: (?>[a-z]+) \:\] |
6125             \[\:\^ (?>[a-z]+) \:\] |
6126             [\$\@\/] |
6127             \\ (?:$q_char) |
6128             (?:$q_char)
6129             ))/oxmsg;
6130 2         72  
6131 2 50 33     10 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6132             for (my $i=0; $i <= $#char; $i++) {
6133             if (0) {
6134             }
6135 2         15  
6136 0         0 # open character class [...]
6137 0 0       0 elsif ($char[$i] eq '[') {
6138 0         0 my $left = $i;
6139             if ($char[$i+1] eq ']') {
6140 0         0 $i++;
6141 0 0       0 }
6142 0         0 while (1) {
6143             if (++$i > $#char) {
6144 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6145 0         0 }
6146             if ($char[$i] eq ']') {
6147             my $right = $i;
6148 0         0  
6149             # [...]
6150 0         0 splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
6151 0         0  
6152             $i = $left;
6153             last;
6154             }
6155             }
6156             }
6157              
6158 0         0 # open character class [^...]
6159 0 0       0 elsif ($char[$i] eq '[^') {
6160 0         0 my $left = $i;
6161             if ($char[$i+1] eq ']') {
6162 0         0 $i++;
6163 0 0       0 }
6164 0         0 while (1) {
6165             if (++$i > $#char) {
6166 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6167 0         0 }
6168             if ($char[$i] eq ']') {
6169             my $right = $i;
6170 0         0  
6171             # [^...]
6172 0         0 splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6173 0         0  
6174             $i = $left;
6175             last;
6176             }
6177             }
6178             }
6179              
6180 0         0 # escape $ @ / and \
6181             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6182             $char[$i] = '\\' . $char[$i];
6183             }
6184              
6185 0         0 # rewrite character class or escape character
6186             elsif (my $char = character_class($char[$i],$modifier)) {
6187             $char[$i] = $char;
6188             }
6189              
6190 0 0       0 # /i modifier
6191 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
6192             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
6193             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
6194 0         0 }
6195             else {
6196             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
6197             }
6198             }
6199              
6200 0 0       0 # quote character before ? + * {
6201             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6202             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6203 0         0 }
6204             else {
6205             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6206             }
6207             }
6208 0         0 }
6209 2         6  
6210             $delimiter = '/';
6211 2         2 $end_delimiter = '/';
6212 2         4  
6213             $modifier =~ tr/i//d;
6214             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6215             }
6216              
6217             #
6218             # escape regexp (m''b, qr''b)
6219 2     0 0 15 #
6220             sub e_qr_qb {
6221             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6222 0         0  
6223             # split regexp
6224             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6225 0         0  
6226 0 0       0 # unescape character
    0          
6227             for (my $i=0; $i <= $#char; $i++) {
6228             if (0) {
6229             }
6230 0         0  
6231             # remain \\
6232             elsif ($char[$i] eq '\\\\') {
6233             }
6234              
6235 0         0 # escape $ @ / and \
6236             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6237             $char[$i] = '\\' . $char[$i];
6238             }
6239 0         0 }
6240 0         0  
6241 0         0 $delimiter = '/';
6242             $end_delimiter = '/';
6243             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6244             }
6245              
6246             #
6247             # escape regexp (s/here//)
6248 0     76 0 0 #
6249 76   100     205 sub e_s1 {
6250             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6251 76         292 $modifier ||= '';
6252 76 50       141  
6253 76         233 $modifier =~ tr/p//d;
6254 0         0 if ($modifier =~ /([adlu])/oxms) {
6255 0 0       0 my $line = 0;
6256 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6257 0         0 if ($filename ne __FILE__) {
6258             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6259             last;
6260 0         0 }
6261             }
6262             die qq{Unsupported modifier "$1" used at line $line.\n};
6263 0         0 }
6264              
6265             $slash = 'div';
6266 76 100       141  
    50          
6267 76         254 # literal null string pattern
6268 8         11 if ($string eq '') {
6269 8         8 $modifier =~ tr/bB//d;
6270             $modifier =~ tr/i//d;
6271             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6272             }
6273              
6274             # /b /B modifier
6275             elsif ($modifier =~ tr/bB//d) {
6276 8 0       49  
6277 0         0 # choice again delimiter
6278 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6279 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6280 0         0 my %octet = map {$_ => 1} @char;
6281 0         0 if (not $octet{')'}) {
6282             $delimiter = '(';
6283             $end_delimiter = ')';
6284 0         0 }
6285 0         0 elsif (not $octet{'}'}) {
6286             $delimiter = '{';
6287             $end_delimiter = '}';
6288 0         0 }
6289 0         0 elsif (not $octet{']'}) {
6290             $delimiter = '[';
6291             $end_delimiter = ']';
6292 0         0 }
6293 0         0 elsif (not $octet{'>'}) {
6294             $delimiter = '<';
6295             $end_delimiter = '>';
6296 0         0 }
6297 0 0       0 else {
6298 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6299 0         0 if (not $octet{$char}) {
6300 0         0 $delimiter = $char;
6301             $end_delimiter = $char;
6302             last;
6303             }
6304             }
6305             }
6306 0         0 }
6307 0         0  
6308             my $prematch = '';
6309             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6310 0 100       0 }
6311 68         215  
6312             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6313             my $metachar = qr/[\@\\|[\]{^]/oxms;
6314 68         259  
6315             # split regexp
6316             my @char = $string =~ /\G((?>
6317             [^\\\$\@\[\(] |
6318             \\ (?>[1-9][0-9]*) |
6319             \\g (?>\s*) (?>[1-9][0-9]*) |
6320             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6321             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6322             \\x (?>[0-9A-Fa-f]{1,2}) |
6323             \\ (?>[0-7]{2,3}) |
6324             \\c [\x40-\x5F] |
6325             \\x\{ (?>[0-9A-Fa-f]+) \} |
6326             \\o\{ (?>[0-7]+) \} |
6327             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6328             \\ $q_char |
6329             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6330             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6331             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6332             [\$\@] $qq_variable |
6333             \$ (?>\s* [0-9]+) |
6334             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6335             \$ \$ (?![\w\{]) |
6336             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6337             \[\^ |
6338             \[\: (?>[a-z]+) :\] |
6339             \[\:\^ (?>[a-z]+) :\] |
6340             \(\? |
6341             $q_char
6342             ))/oxmsg;
6343 68 50       16212  
6344 68         451 # choice again delimiter
  0         0  
6345 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6346 0         0 my %octet = map {$_ => 1} @char;
6347 0         0 if (not $octet{')'}) {
6348             $delimiter = '(';
6349             $end_delimiter = ')';
6350 0         0 }
6351 0         0 elsif (not $octet{'}'}) {
6352             $delimiter = '{';
6353             $end_delimiter = '}';
6354 0         0 }
6355 0         0 elsif (not $octet{']'}) {
6356             $delimiter = '[';
6357             $end_delimiter = ']';
6358 0         0 }
6359 0         0 elsif (not $octet{'>'}) {
6360             $delimiter = '<';
6361             $end_delimiter = '>';
6362 0         0 }
6363 0 0       0 else {
6364 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6365 0         0 if (not $octet{$char}) {
6366 0         0 $delimiter = $char;
6367             $end_delimiter = $char;
6368             last;
6369             }
6370             }
6371             }
6372             }
6373 0         0  
  68         134  
6374             # count '('
6375 253         438 my $parens = grep { $_ eq '(' } @char;
6376 68         101  
6377 68         108 my $left_e = 0;
6378             my $right_e = 0;
6379             for (my $i=0; $i <= $#char; $i++) {
6380 68 50 33     175  
    50 33        
    100          
    100          
    50          
    50          
6381 195         1125 # "\L\u" --> "\u\L"
6382             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6383             @char[$i,$i+1] = @char[$i+1,$i];
6384             }
6385              
6386 0         0 # "\U\l" --> "\l\U"
6387             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6388             @char[$i,$i+1] = @char[$i+1,$i];
6389             }
6390              
6391 0         0 # octal escape sequence
6392             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6393             $char[$i] = Eusascii::octchr($1);
6394             }
6395              
6396 1         3 # hexadecimal escape sequence
6397             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6398             $char[$i] = Eusascii::hexchr($1);
6399             }
6400              
6401             # \b{...} --> b\{...}
6402             # \B{...} --> B\{...}
6403             # \N{CHARNAME} --> N\{CHARNAME}
6404             # \p{PROPERTY} --> p\{PROPERTY}
6405 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6406             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6407             $char[$i] = $1 . '\\' . $2;
6408             }
6409              
6410 0         0 # \p, \P, \X --> p, P, X
6411             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6412             $char[$i] = $1;
6413 0 50 66     0 }
    100 66        
    50 100        
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6414              
6415             if (0) {
6416             }
6417 195         661  
6418 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6419 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6420             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)) {
6421             $char[$i] .= join '', splice @char, $i+1, 3;
6422 0         0 }
6423             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)) {
6424             $char[$i] .= join '', splice @char, $i+1, 2;
6425 0         0 }
6426             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)) {
6427             $char[$i] .= join '', splice @char, $i+1, 1;
6428             }
6429             }
6430              
6431 0         0 # open character class [...]
6432 13 50       19 elsif ($char[$i] eq '[') {
6433 13         45 my $left = $i;
6434             if ($char[$i+1] eq ']') {
6435 0         0 $i++;
6436 13 50       21 }
6437 58         94 while (1) {
6438             if (++$i > $#char) {
6439 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6440 58         160 }
6441             if ($char[$i] eq ']') {
6442             my $right = $i;
6443 13 50       23  
6444 13         84 # [...]
  0         0  
6445             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6446             splice @char, $left, $right-$left+1, sprintf(q{@{[Eusascii::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6447 0         0 }
6448             else {
6449             splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
6450 13         58 }
6451 13         25  
6452             $i = $left;
6453             last;
6454             }
6455             }
6456             }
6457              
6458 13         46 # open character class [^...]
6459 0 0       0 elsif ($char[$i] eq '[^') {
6460 0         0 my $left = $i;
6461             if ($char[$i+1] eq ']') {
6462 0         0 $i++;
6463 0 0       0 }
6464 0         0 while (1) {
6465             if (++$i > $#char) {
6466 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6467 0         0 }
6468             if ($char[$i] eq ']') {
6469             my $right = $i;
6470 0 0       0  
6471 0         0 # [^...]
  0         0  
6472             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6473             splice @char, $left, $right-$left+1, sprintf(q{@{[Eusascii::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6474 0         0 }
6475             else {
6476             splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6477 0         0 }
6478 0         0  
6479             $i = $left;
6480             last;
6481             }
6482             }
6483             }
6484              
6485 0         0 # rewrite character class or escape character
6486             elsif (my $char = character_class($char[$i],$modifier)) {
6487             $char[$i] = $char;
6488             }
6489              
6490 7 50       15 # /i modifier
6491 3         5 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
6492             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
6493             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
6494 3         7 }
6495             else {
6496             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
6497             }
6498             }
6499              
6500 0 0       0 # \u \l \U \L \F \Q \E
6501 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6502             if ($right_e < $left_e) {
6503             $char[$i] = '\\' . $char[$i];
6504             }
6505 0         0 }
6506 0         0 elsif ($char[$i] eq '\u') {
6507             $char[$i] = '@{[Eusascii::ucfirst qq<';
6508             $left_e++;
6509 0         0 }
6510 0         0 elsif ($char[$i] eq '\l') {
6511             $char[$i] = '@{[Eusascii::lcfirst qq<';
6512             $left_e++;
6513 0         0 }
6514 0         0 elsif ($char[$i] eq '\U') {
6515             $char[$i] = '@{[Eusascii::uc qq<';
6516             $left_e++;
6517 0         0 }
6518 0         0 elsif ($char[$i] eq '\L') {
6519             $char[$i] = '@{[Eusascii::lc qq<';
6520             $left_e++;
6521 0         0 }
6522 0         0 elsif ($char[$i] eq '\F') {
6523             $char[$i] = '@{[Eusascii::fc qq<';
6524             $left_e++;
6525 0         0 }
6526 0         0 elsif ($char[$i] eq '\Q') {
6527             $char[$i] = '@{[CORE::quotemeta qq<';
6528             $left_e++;
6529 0 0       0 }
6530 0         0 elsif ($char[$i] eq '\E') {
6531 0         0 if ($right_e < $left_e) {
6532             $char[$i] = '>]}';
6533             $right_e++;
6534 0         0 }
6535             else {
6536             $char[$i] = '';
6537             }
6538 0         0 }
6539 0 0       0 elsif ($char[$i] eq '\Q') {
6540 0         0 while (1) {
6541             if (++$i > $#char) {
6542 0 0       0 last;
6543 0         0 }
6544             if ($char[$i] eq '\E') {
6545             last;
6546             }
6547             }
6548             }
6549             elsif ($char[$i] eq '\E') {
6550             }
6551              
6552             # \0 --> \0
6553             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6554             }
6555              
6556             # \g{N}, \g{-N}
6557              
6558             # P.108 Using Simple Patterns
6559             # in Chapter 7: In the World of Regular Expressions
6560             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6561              
6562             # P.221 Capturing
6563             # in Chapter 5: Pattern Matching
6564             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6565              
6566             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6567             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6568             }
6569              
6570             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6571             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6572             }
6573              
6574             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6575             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6576             }
6577              
6578             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6579             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6580             }
6581              
6582 0 0       0 # $0 --> $0
6583 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6584             if ($ignorecase) {
6585             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6586             }
6587 0 0       0 }
6588 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6589             if ($ignorecase) {
6590             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6591             }
6592             }
6593              
6594             # $$ --> $$
6595             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6596             }
6597              
6598             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6599 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6600 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6601 0         0 $char[$i] = e_capture($1);
6602             if ($ignorecase) {
6603             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6604             }
6605 0         0 }
6606 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6607 0         0 $char[$i] = e_capture($1);
6608             if ($ignorecase) {
6609             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6610             }
6611             }
6612              
6613 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6614 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) {
6615 0         0 $char[$i] = e_capture($1.'->'.$2);
6616             if ($ignorecase) {
6617             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6618             }
6619             }
6620              
6621 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6622 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) {
6623 0         0 $char[$i] = e_capture($1.'->'.$2);
6624             if ($ignorecase) {
6625             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6626             }
6627             }
6628              
6629 0         0 # $$foo
6630 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6631 0         0 $char[$i] = e_capture($1);
6632             if ($ignorecase) {
6633             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6634             }
6635             }
6636              
6637 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
6638 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6639             if ($ignorecase) {
6640             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::PREMATCH())]}';
6641 0         0 }
6642             else {
6643             $char[$i] = '@{[Eusascii::PREMATCH()]}';
6644             }
6645             }
6646              
6647 4 50       14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
6648 4         15 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6649             if ($ignorecase) {
6650             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::MATCH())]}';
6651 0         0 }
6652             else {
6653             $char[$i] = '@{[Eusascii::MATCH()]}';
6654             }
6655             }
6656              
6657 4 50       16 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
6658 3         12 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6659             if ($ignorecase) {
6660             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::POSTMATCH())]}';
6661 0         0 }
6662             else {
6663             $char[$i] = '@{[Eusascii::POSTMATCH()]}';
6664             }
6665             }
6666              
6667 3 0       13 # ${ foo }
6668 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) {
6669             if ($ignorecase) {
6670             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6671             }
6672             }
6673              
6674 0         0 # ${ ... }
6675 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6676 0         0 $char[$i] = e_capture($1);
6677             if ($ignorecase) {
6678             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6679             }
6680             }
6681              
6682 0         0 # $scalar or @array
6683 4 50       21 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6684 4         20 $char[$i] = e_string($char[$i]);
6685             if ($ignorecase) {
6686             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6687             }
6688             }
6689              
6690 0 50       0 # quote character before ? + * {
6691             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6692             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6693 13         79 }
6694             else {
6695             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6696             }
6697             }
6698             }
6699 13         67  
6700 68         154 # make regexp string
6701 68 50       113 my $prematch = '';
6702 68         168 $modifier =~ tr/i//d;
6703             if ($left_e > $right_e) {
6704 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6705             }
6706             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6707             }
6708              
6709             #
6710             # escape regexp (s'here'' or s'here''b)
6711 68     21 0 714 #
6712 21   100     47 sub e_s1_q {
6713             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6714 21         69 $modifier ||= '';
6715 21 50       26  
6716 21         38 $modifier =~ tr/p//d;
6717 0         0 if ($modifier =~ /([adlu])/oxms) {
6718 0 0       0 my $line = 0;
6719 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6720 0         0 if ($filename ne __FILE__) {
6721             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6722             last;
6723 0         0 }
6724             }
6725             die qq{Unsupported modifier "$1" used at line $line.\n};
6726 0         0 }
6727              
6728             $slash = 'div';
6729 21 100       32  
    50          
6730 21         55 # literal null string pattern
6731 8         11 if ($string eq '') {
6732 8         10 $modifier =~ tr/bB//d;
6733             $modifier =~ tr/i//d;
6734             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6735             }
6736              
6737 8         43 # with /b /B modifier
6738             elsif ($modifier =~ tr/bB//d) {
6739             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6740             }
6741              
6742 0         0 # without /b /B modifier
6743             else {
6744             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6745             }
6746             }
6747              
6748             #
6749             # escape regexp (s'here'')
6750 13     13 0 41 #
6751             sub e_s1_qt {
6752 13 50       40 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6753              
6754             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6755 13         26  
6756             # split regexp
6757             my @char = $string =~ /\G((?>
6758             [^\\\[\$\@\/] |
6759             [\x00-\xFF] |
6760             \[\^ |
6761             \[\: (?>[a-z]+) \:\] |
6762             \[\:\^ (?>[a-z]+) \:\] |
6763             [\$\@\/] |
6764             \\ (?:$q_char) |
6765             (?:$q_char)
6766             ))/oxmsg;
6767 13         214  
6768 13 50 33     40 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6769             for (my $i=0; $i <= $#char; $i++) {
6770             if (0) {
6771             }
6772 25         90  
6773 0         0 # open character class [...]
6774 0 0       0 elsif ($char[$i] eq '[') {
6775 0         0 my $left = $i;
6776             if ($char[$i+1] eq ']') {
6777 0         0 $i++;
6778 0 0       0 }
6779 0         0 while (1) {
6780             if (++$i > $#char) {
6781 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6782 0         0 }
6783             if ($char[$i] eq ']') {
6784             my $right = $i;
6785 0         0  
6786             # [...]
6787 0         0 splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
6788 0         0  
6789             $i = $left;
6790             last;
6791             }
6792             }
6793             }
6794              
6795 0         0 # open character class [^...]
6796 0 0       0 elsif ($char[$i] eq '[^') {
6797 0         0 my $left = $i;
6798             if ($char[$i+1] eq ']') {
6799 0         0 $i++;
6800 0 0       0 }
6801 0         0 while (1) {
6802             if (++$i > $#char) {
6803 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6804 0         0 }
6805             if ($char[$i] eq ']') {
6806             my $right = $i;
6807 0         0  
6808             # [^...]
6809 0         0 splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6810 0         0  
6811             $i = $left;
6812             last;
6813             }
6814             }
6815             }
6816              
6817 0         0 # escape $ @ / and \
6818             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6819             $char[$i] = '\\' . $char[$i];
6820             }
6821              
6822 0         0 # rewrite character class or escape character
6823             elsif (my $char = character_class($char[$i],$modifier)) {
6824             $char[$i] = $char;
6825             }
6826              
6827 6 0       11 # /i modifier
6828 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
6829             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
6830             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
6831 0         0 }
6832             else {
6833             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
6834             }
6835             }
6836              
6837 0 0       0 # quote character before ? + * {
6838             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6839             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6840 0         0 }
6841             else {
6842             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6843             }
6844             }
6845 0         0 }
6846 13         24  
6847 13         20 $modifier =~ tr/i//d;
6848 13         16 $delimiter = '/';
6849 13         16 $end_delimiter = '/';
6850             my $prematch = '';
6851             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6852             }
6853              
6854             #
6855             # escape regexp (s'here''b)
6856 13     0 0 88 #
6857             sub e_s1_qb {
6858             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6859 0         0  
6860             # split regexp
6861             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6862 0         0  
6863 0 0       0 # unescape character
    0          
6864             for (my $i=0; $i <= $#char; $i++) {
6865             if (0) {
6866             }
6867 0         0  
6868             # remain \\
6869             elsif ($char[$i] eq '\\\\') {
6870             }
6871              
6872 0         0 # escape $ @ / and \
6873             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6874             $char[$i] = '\\' . $char[$i];
6875             }
6876 0         0 }
6877 0         0  
6878 0         0 $delimiter = '/';
6879 0         0 $end_delimiter = '/';
6880             my $prematch = '';
6881             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6882             }
6883              
6884             #
6885             # escape regexp (s''here')
6886 0     16 0 0 #
6887             sub e_s2_q {
6888 16         34 my($ope,$delimiter,$end_delimiter,$string) = @_;
6889              
6890 16         22 $slash = 'div';
6891 16         98  
6892 16 100       45 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
6893             for (my $i=0; $i <= $#char; $i++) {
6894             if (0) {
6895             }
6896 9         40  
6897             # not escape \\
6898             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6899             }
6900              
6901 0         0 # escape $ @ / and \
6902             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6903             $char[$i] = '\\' . $char[$i];
6904             }
6905 5         15 }
6906              
6907             return join '', $ope, $delimiter, @char, $end_delimiter;
6908             }
6909              
6910             #
6911             # escape regexp (s/here/and here/modifier)
6912 16     97 0 337 #
6913 97   100     783 sub e_sub {
6914             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6915 97         429 $modifier ||= '';
6916 97 50       187  
6917 97         268 $modifier =~ tr/p//d;
6918 0         0 if ($modifier =~ /([adlu])/oxms) {
6919 0 0       0 my $line = 0;
6920 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6921 0         0 if ($filename ne __FILE__) {
6922             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6923             last;
6924 0         0 }
6925             }
6926             die qq{Unsupported modifier "$1" used at line $line.\n};
6927 0 100       0 }
6928 97         244  
6929 36         40 if ($variable eq '') {
6930             $variable = '$_';
6931             $bind_operator = ' =~ ';
6932 36         46 }
6933              
6934             $slash = 'div';
6935              
6936             # P.128 Start of match (or end of previous match): \G
6937             # P.130 Advanced Use of \G with Perl
6938             # in Chapter 3: Overview of Regular Expression Features and Flavors
6939             # P.312 Iterative Matching: Scalar Context, with /g
6940             # in Chapter 7: Perl
6941             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6942              
6943             # P.181 Where You Left Off: The \G Assertion
6944             # in Chapter 5: Pattern Matching
6945             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6946              
6947             # P.220 Where You Left Off: The \G Assertion
6948             # in Chapter 5: Pattern Matching
6949 97         156 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6950 97         155  
6951             my $e_modifier = $modifier =~ tr/e//d;
6952 97         136 my $r_modifier = $modifier =~ tr/r//d;
6953 97 50       132  
6954 97         233 my $my = '';
6955 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6956 0         0 $my = $variable;
6957             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6958             $variable =~ s/ = .+ \z//oxms;
6959 0         0 }
6960 97         237  
6961             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6962             $variable_basename =~ s/ \s+ \z//oxms;
6963 97         169  
6964 97 100       137 # quote replacement string
6965 97         209 my $e_replacement = '';
6966 17         31 if ($e_modifier >= 1) {
6967             $e_replacement = e_qq('', '', '', $replacement);
6968             $e_modifier--;
6969 17 100       37 }
6970 80         194 else {
6971             if ($delimiter2 eq "'") {
6972             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6973 16         29 }
6974             else {
6975             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6976             }
6977 64         156 }
6978              
6979             my $sub = '';
6980 97 100       169  
6981 97 100       186 # with /r
6982             if ($r_modifier) {
6983             if (0) {
6984             }
6985 8         18  
6986 0 50       0 # s///gr without multibyte anchoring
6987             elsif ($modifier =~ /g/oxms) {
6988             $sub = sprintf(
6989             # 1 2 3 4 5
6990             q,
6991              
6992             $variable, # 1
6993             ($delimiter1 eq "'") ? # 2
6994             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6995             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6996             $s_matched, # 3
6997             $e_replacement, # 4
6998             '$Eusascii::re_r=CORE::eval $Eusascii::re_r; ' x $e_modifier, # 5
6999             );
7000             }
7001              
7002             # s///r
7003 4         13 else {
7004              
7005 4 50       5 my $prematch = q{$`};
7006              
7007             $sub = sprintf(
7008             # 1 2 3 4 5 6 7
7009             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Eusascii::re_r=%s; %s"%s$Eusascii::re_r$'" } : %s>,
7010              
7011             $variable, # 1
7012             ($delimiter1 eq "'") ? # 2
7013             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7014             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7015             $s_matched, # 3
7016             $e_replacement, # 4
7017             '$Eusascii::re_r=CORE::eval $Eusascii::re_r; ' x $e_modifier, # 5
7018             $prematch, # 6
7019             $variable, # 7
7020             );
7021             }
7022 4 50       14  
7023 8         24 # $var !~ s///r doesn't make sense
7024             if ($bind_operator =~ / !~ /oxms) {
7025             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7026             }
7027             }
7028              
7029 0 100       0 # without /r
7030             else {
7031             if (0) {
7032             }
7033 89         197  
7034 0 100       0 # s///g without multibyte anchoring
    100          
7035             elsif ($modifier =~ /g/oxms) {
7036             $sub = sprintf(
7037             # 1 2 3 4 5 6 7 8
7038             q,
7039              
7040             $variable, # 1
7041             ($delimiter1 eq "'") ? # 2
7042             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7043             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7044             $s_matched, # 3
7045             $e_replacement, # 4
7046             '$Eusascii::re_r=CORE::eval $Eusascii::re_r; ' x $e_modifier, # 5
7047             $variable, # 6
7048             $variable, # 7
7049             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7050             );
7051             }
7052              
7053             # s///
7054 22         68 else {
7055              
7056 67 100       109 my $prematch = q{$`};
    100          
7057              
7058             $sub = sprintf(
7059              
7060             ($bind_operator =~ / =~ /oxms) ?
7061              
7062             # 1 2 3 4 5 6 7 8
7063             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Eusascii::re_r=%s; %s%s="%s$Eusascii::re_r$'"; 1 } : undef> :
7064              
7065             # 1 2 3 4 5 6 7 8
7066             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Eusascii::re_r=%s; %s%s="%s$Eusascii::re_r$'"; undef }>,
7067              
7068             $variable, # 1
7069             $bind_operator, # 2
7070             ($delimiter1 eq "'") ? # 3
7071             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7072             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7073             $s_matched, # 4
7074             $e_replacement, # 5
7075             '$Eusascii::re_r=CORE::eval $Eusascii::re_r; ' x $e_modifier, # 6
7076             $variable, # 7
7077             $prematch, # 8
7078             );
7079             }
7080             }
7081 67 50       358  
7082 97         261 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7083             if ($my ne '') {
7084             $sub = "($my, $sub)[1]";
7085             }
7086 0         0  
7087 97         148 # clear s/// variable
7088             $sub_variable = '';
7089 97         128 $bind_operator = '';
7090              
7091             return $sub;
7092             }
7093              
7094             #
7095             # escape regexp of split qr//
7096 97     74 0 699 #
7097 74   100     330 sub e_split {
7098             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7099 74         342 $modifier ||= '';
7100 74 50       127  
7101 74         188 $modifier =~ tr/p//d;
7102 0         0 if ($modifier =~ /([adlu])/oxms) {
7103 0 0       0 my $line = 0;
7104 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7105 0         0 if ($filename ne __FILE__) {
7106             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7107             last;
7108 0         0 }
7109             }
7110             die qq{Unsupported modifier "$1" used at line $line.\n};
7111 0         0 }
7112              
7113             $slash = 'div';
7114 74 50       137  
7115 74         157 # /b /B modifier
7116             if ($modifier =~ tr/bB//d) {
7117             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7118 0 50       0 }
7119 74         203  
7120             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7121             my $metachar = qr/[\@\\|[\]{^]/oxms;
7122 74         283  
7123             # split regexp
7124             my @char = $string =~ /\G((?>
7125             [^\\\$\@\[\(] |
7126             \\x (?>[0-9A-Fa-f]{1,2}) |
7127             \\ (?>[0-7]{2,3}) |
7128             \\c [\x40-\x5F] |
7129             \\x\{ (?>[0-9A-Fa-f]+) \} |
7130             \\o\{ (?>[0-7]+) \} |
7131             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7132             \\ $q_char |
7133             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7134             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7135             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7136             [\$\@] $qq_variable |
7137             \$ (?>\s* [0-9]+) |
7138             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7139             \$ \$ (?![\w\{]) |
7140             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7141             \[\^ |
7142             \[\: (?>[a-z]+) :\] |
7143             \[\:\^ (?>[a-z]+) :\] |
7144             \(\? |
7145             $q_char
7146 74         9474 ))/oxmsg;
7147 74         274  
7148 74         113 my $left_e = 0;
7149             my $right_e = 0;
7150             for (my $i=0; $i <= $#char; $i++) {
7151 74 50 33     359  
    50 33        
    100          
    100          
    50          
    50          
7152 249         1227 # "\L\u" --> "\u\L"
7153             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7154             @char[$i,$i+1] = @char[$i+1,$i];
7155             }
7156              
7157 0         0 # "\U\l" --> "\l\U"
7158             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7159             @char[$i,$i+1] = @char[$i+1,$i];
7160             }
7161              
7162 0         0 # octal escape sequence
7163             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7164             $char[$i] = Eusascii::octchr($1);
7165             }
7166              
7167 1         3 # hexadecimal escape sequence
7168             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7169             $char[$i] = Eusascii::hexchr($1);
7170             }
7171              
7172             # \b{...} --> b\{...}
7173             # \B{...} --> B\{...}
7174             # \N{CHARNAME} --> N\{CHARNAME}
7175             # \p{PROPERTY} --> p\{PROPERTY}
7176 1         3 # \P{PROPERTY} --> P\{PROPERTY}
7177             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7178             $char[$i] = $1 . '\\' . $2;
7179             }
7180              
7181 0         0 # \p, \P, \X --> p, P, X
7182             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7183             $char[$i] = $1;
7184 0 50 100     0 }
    100 33        
    50 33        
    100 100        
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
7185              
7186             if (0) {
7187             }
7188 249         798  
7189 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7190 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7191             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)) {
7192             $char[$i] .= join '', splice @char, $i+1, 3;
7193 0         0 }
7194             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)) {
7195             $char[$i] .= join '', splice @char, $i+1, 2;
7196 0         0 }
7197             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)) {
7198             $char[$i] .= join '', splice @char, $i+1, 1;
7199             }
7200             }
7201              
7202 0         0 # open character class [...]
7203 3 50       3 elsif ($char[$i] eq '[') {
7204 3         14 my $left = $i;
7205             if ($char[$i+1] eq ']') {
7206 0         0 $i++;
7207 3 50       5 }
7208 7         12 while (1) {
7209             if (++$i > $#char) {
7210 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7211 7         10 }
7212             if ($char[$i] eq ']') {
7213             my $right = $i;
7214 3 50       4  
7215 3         14 # [...]
  0         0  
7216             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7217             splice @char, $left, $right-$left+1, sprintf(q{@{[Eusascii::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7218 0         0 }
7219             else {
7220             splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
7221 3         10 }
7222 3         6  
7223             $i = $left;
7224             last;
7225             }
7226             }
7227             }
7228              
7229 3         6 # open character class [^...]
7230 0 0       0 elsif ($char[$i] eq '[^') {
7231 0         0 my $left = $i;
7232             if ($char[$i+1] eq ']') {
7233 0         0 $i++;
7234 0 0       0 }
7235 0         0 while (1) {
7236             if (++$i > $#char) {
7237 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7238 0         0 }
7239             if ($char[$i] eq ']') {
7240             my $right = $i;
7241 0 0       0  
7242 0         0 # [^...]
  0         0  
7243             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7244             splice @char, $left, $right-$left+1, sprintf(q{@{[Eusascii::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7245 0         0 }
7246             else {
7247             splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7248 0         0 }
7249 0         0  
7250             $i = $left;
7251             last;
7252             }
7253             }
7254             }
7255              
7256 0         0 # rewrite character class or escape character
7257             elsif (my $char = character_class($char[$i],$modifier)) {
7258             $char[$i] = $char;
7259             }
7260              
7261             # P.794 29.2.161. split
7262             # in Chapter 29: Functions
7263             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7264              
7265             # P.951 split
7266             # in Chapter 27: Functions
7267             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7268              
7269             # said "The //m modifier is assumed when you split on the pattern /^/",
7270             # but perl5.008 is not so. Therefore, this software adds //m.
7271             # (and so on)
7272              
7273 1         4 # split(m/^/) --> split(m/^/m)
7274             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7275             $modifier .= 'm';
7276             }
7277              
7278 7 0       26 # /i modifier
7279 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
7280             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
7281             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
7282 0         0 }
7283             else {
7284             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
7285             }
7286             }
7287              
7288 0 0       0 # \u \l \U \L \F \Q \E
7289 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7290             if ($right_e < $left_e) {
7291             $char[$i] = '\\' . $char[$i];
7292             }
7293 0         0 }
7294 0         0 elsif ($char[$i] eq '\u') {
7295             $char[$i] = '@{[Eusascii::ucfirst qq<';
7296             $left_e++;
7297 0         0 }
7298 0         0 elsif ($char[$i] eq '\l') {
7299             $char[$i] = '@{[Eusascii::lcfirst qq<';
7300             $left_e++;
7301 0         0 }
7302 0         0 elsif ($char[$i] eq '\U') {
7303             $char[$i] = '@{[Eusascii::uc qq<';
7304             $left_e++;
7305 0         0 }
7306 0         0 elsif ($char[$i] eq '\L') {
7307             $char[$i] = '@{[Eusascii::lc qq<';
7308             $left_e++;
7309 0         0 }
7310 0         0 elsif ($char[$i] eq '\F') {
7311             $char[$i] = '@{[Eusascii::fc qq<';
7312             $left_e++;
7313 0         0 }
7314 0         0 elsif ($char[$i] eq '\Q') {
7315             $char[$i] = '@{[CORE::quotemeta qq<';
7316             $left_e++;
7317 0 0       0 }
7318 0         0 elsif ($char[$i] eq '\E') {
7319 0         0 if ($right_e < $left_e) {
7320             $char[$i] = '>]}';
7321             $right_e++;
7322 0         0 }
7323             else {
7324             $char[$i] = '';
7325             }
7326 0         0 }
7327 0 0       0 elsif ($char[$i] eq '\Q') {
7328 0         0 while (1) {
7329             if (++$i > $#char) {
7330 0 0       0 last;
7331 0         0 }
7332             if ($char[$i] eq '\E') {
7333             last;
7334             }
7335             }
7336             }
7337             elsif ($char[$i] eq '\E') {
7338             }
7339              
7340 0 0       0 # $0 --> $0
7341 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7342             if ($ignorecase) {
7343             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7344             }
7345 0 0       0 }
7346 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7347             if ($ignorecase) {
7348             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7349             }
7350             }
7351              
7352             # $$ --> $$
7353             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7354             }
7355              
7356             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7357 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7358 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7359 0         0 $char[$i] = e_capture($1);
7360             if ($ignorecase) {
7361             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7362             }
7363 0         0 }
7364 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7365 0         0 $char[$i] = e_capture($1);
7366             if ($ignorecase) {
7367             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7368             }
7369             }
7370              
7371 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7372 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) {
7373 0         0 $char[$i] = e_capture($1.'->'.$2);
7374             if ($ignorecase) {
7375             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7376             }
7377             }
7378              
7379 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7380 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) {
7381 0         0 $char[$i] = e_capture($1.'->'.$2);
7382             if ($ignorecase) {
7383             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7384             }
7385             }
7386              
7387 0         0 # $$foo
7388 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7389 0         0 $char[$i] = e_capture($1);
7390             if ($ignorecase) {
7391             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7392             }
7393             }
7394              
7395 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
7396 12         33 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7397             if ($ignorecase) {
7398             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::PREMATCH())]}';
7399 0         0 }
7400             else {
7401             $char[$i] = '@{[Eusascii::PREMATCH()]}';
7402             }
7403             }
7404              
7405 12 50       50 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
7406 12         38 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7407             if ($ignorecase) {
7408             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::MATCH())]}';
7409 0         0 }
7410             else {
7411             $char[$i] = '@{[Eusascii::MATCH()]}';
7412             }
7413             }
7414              
7415 12 50       57 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
7416 9         35 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7417             if ($ignorecase) {
7418             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::POSTMATCH())]}';
7419 0         0 }
7420             else {
7421             $char[$i] = '@{[Eusascii::POSTMATCH()]}';
7422             }
7423             }
7424              
7425 9 0       45 # ${ foo }
7426 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) {
7427             if ($ignorecase) {
7428             $char[$i] = '@{[Eusascii::ignorecase(' . $1 . ')]}';
7429             }
7430             }
7431              
7432 0         0 # ${ ... }
7433 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7434 0         0 $char[$i] = e_capture($1);
7435             if ($ignorecase) {
7436             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7437             }
7438             }
7439              
7440 0         0 # $scalar or @array
7441 3 50       12 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7442 3         16 $char[$i] = e_string($char[$i]);
7443             if ($ignorecase) {
7444             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7445             }
7446             }
7447              
7448 0 50       0 # quote character before ? + * {
7449             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7450             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7451 1         6 }
7452             else {
7453             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7454             }
7455             }
7456             }
7457 0         0  
7458 74 50       153 # make regexp string
7459 74         191 $modifier =~ tr/i//d;
7460             if ($left_e > $right_e) {
7461 0         0 return join '', 'Eusascii::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7462             }
7463             return join '', 'Eusascii::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7464             }
7465              
7466             #
7467             # escape regexp of split qr''
7468 74     0 0 750 #
7469 0   0       sub e_split_q {
7470             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7471 0           $modifier ||= '';
7472 0 0          
7473 0           $modifier =~ tr/p//d;
7474 0           if ($modifier =~ /([adlu])/oxms) {
7475 0 0         my $line = 0;
7476 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7477 0           if ($filename ne __FILE__) {
7478             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7479             last;
7480 0           }
7481             }
7482             die qq{Unsupported modifier "$1" used at line $line.\n};
7483 0           }
7484              
7485             $slash = 'div';
7486 0 0          
7487 0           # /b /B modifier
7488             if ($modifier =~ tr/bB//d) {
7489             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7490 0 0         }
7491              
7492             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7493 0            
7494             # split regexp
7495             my @char = $string =~ /\G((?>
7496             [^\\\[] |
7497             [\x00-\xFF] |
7498             \[\^ |
7499             \[\: (?>[a-z]+) \:\] |
7500             \[\:\^ (?>[a-z]+) \:\] |
7501             \\ (?:$q_char) |
7502             (?:$q_char)
7503             ))/oxmsg;
7504 0            
7505 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7506             for (my $i=0; $i <= $#char; $i++) {
7507             if (0) {
7508             }
7509 0            
7510 0           # open character class [...]
7511 0 0         elsif ($char[$i] eq '[') {
7512 0           my $left = $i;
7513             if ($char[$i+1] eq ']') {
7514 0           $i++;
7515 0 0         }
7516 0           while (1) {
7517             if (++$i > $#char) {
7518 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7519 0           }
7520             if ($char[$i] eq ']') {
7521             my $right = $i;
7522 0            
7523             # [...]
7524 0           splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
7525 0            
7526             $i = $left;
7527             last;
7528             }
7529             }
7530             }
7531              
7532 0           # open character class [^...]
7533 0 0         elsif ($char[$i] eq '[^') {
7534 0           my $left = $i;
7535             if ($char[$i+1] eq ']') {
7536 0           $i++;
7537 0 0         }
7538 0           while (1) {
7539             if (++$i > $#char) {
7540 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7541 0           }
7542             if ($char[$i] eq ']') {
7543             my $right = $i;
7544 0            
7545             # [^...]
7546 0           splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7547 0            
7548             $i = $left;
7549             last;
7550             }
7551             }
7552             }
7553              
7554 0           # rewrite character class or escape character
7555             elsif (my $char = character_class($char[$i],$modifier)) {
7556             $char[$i] = $char;
7557             }
7558              
7559 0           # split(m/^/) --> split(m/^/m)
7560             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7561             $modifier .= 'm';
7562             }
7563              
7564 0 0         # /i modifier
7565 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
7566             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
7567             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
7568 0           }
7569             else {
7570             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
7571             }
7572             }
7573              
7574 0 0         # quote character before ? + * {
7575             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7576             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7577 0           }
7578             else {
7579             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7580             }
7581             }
7582 0           }
7583 0            
7584             $modifier =~ tr/i//d;
7585             return join '', 'Eusascii::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7586             }
7587              
7588             #
7589             # instead of Carp::carp
7590 0     0 0   #
7591 0           sub carp {
7592             my($package,$filename,$line) = caller(1);
7593             print STDERR "@_ at $filename line $line.\n";
7594             }
7595              
7596             #
7597             # instead of Carp::croak
7598 0     0 0   #
7599 0           sub croak {
7600 0           my($package,$filename,$line) = caller(1);
7601             print STDERR "@_ at $filename line $line.\n";
7602             die "\n";
7603             }
7604              
7605             #
7606             # instead of Carp::cluck
7607 0     0 0   #
7608 0           sub cluck {
7609 0           my $i = 0;
7610 0           my @cluck = ();
7611 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7612             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7613 0           $i++;
7614 0           }
7615 0           print STDERR CORE::reverse @cluck;
7616             print STDERR "\n";
7617             print STDERR @_;
7618             }
7619              
7620             #
7621             # instead of Carp::confess
7622 0     0 0   #
7623 0           sub confess {
7624 0           my $i = 0;
7625 0           my @confess = ();
7626 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7627             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7628 0           $i++;
7629 0           }
7630 0           print STDERR CORE::reverse @confess;
7631 0           print STDERR "\n";
7632             print STDERR @_;
7633             die "\n";
7634             }
7635              
7636             1;
7637              
7638             __END__