File Coverage

blib/lib/Eusascii.pm
Criterion Covered Total %
statement 896 3194 28.0
branch 962 2740 35.1
condition 97 355 27.3
subroutine 52 110 47.2
pod 7 74 9.4
total 2014 6473 31.1


line stmt bran cond sub pod time code
1             package Eusascii;
2 204     204   1243 use strict;
  204         324  
  204         5953  
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   2985 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         1130  
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   993 use vars qw($VERSION);
  204         414  
  204         33946  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1974 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         31382 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   28523 CORE::eval q{
  204     204   1204  
  204     76   377  
  204         28743  
  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       94939 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0     0 0 0 return \do { local *_ };
  0         0  
69             }
70              
71             sub qualify ($$) {
72 0     0 0 0 my($name) = @_;
73              
74 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
75 0         0 return $name;
76             }
77             elsif (Eusascii::index($name,'::') >= 0) {
78 0         0 return $name;
79             }
80             elsif (Eusascii::index($name,"'") >= 0) {
81 0         0 return $name;
82             }
83              
84             # special character, "^xyz"
85             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
86              
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
89 0         0 return 'main::' . $name;
90             }
91              
92             # Global names
93             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
94 0         0 return 'main::' . $name;
95             }
96              
97             # or other
98             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             elsif (defined $_[1]) {
103 0         0 return $_[1] . '::' . $name;
104             }
105             else {
106 0         0 return (caller)[0] . '::' . $name;
107             }
108             }
109              
110             sub qualify_to_ref ($;$) {
111 0 0   0 0 0 if (defined $_[1]) {
112 204     204   2158 no strict qw(refs);
  204         389  
  204         15887  
113 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
114             }
115             else {
116 204     204   1403 no strict qw(refs);
  204     0   370  
  204         50058  
117 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
118             }
119             }
120             }
121              
122             # P.714 29.2.39. flock
123             # in Chapter 29: Functions
124             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
125              
126             # P.863 flock
127             # in Chapter 27: Functions
128             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
129              
130             sub LOCK_SH() {1}
131             sub LOCK_EX() {2}
132             sub LOCK_UN() {8}
133             sub LOCK_NB() {4}
134              
135             # instead of Carp.pm
136             sub carp;
137             sub croak;
138             sub cluck;
139             sub confess;
140              
141             # 6.18. Matching Multiple-Byte Characters
142             # in Chapter 6. Pattern Matching
143             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
144             # (and so on)
145              
146             # regexp of character
147             my $your_char = q{[\x00-\xFF]};
148 204     204   1612 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         356  
  204         15394  
149 204     204   1637 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         411  
  204         241042  
150              
151             #
152             # US-ASCII character range per length
153             #
154             my %range_tr = ();
155              
156             #
157             # US-ASCII case conversion
158             #
159             my %lc = ();
160             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
161             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
162             my %uc = ();
163             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
164             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
165             my %fc = ();
166             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
167             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
168              
169             if (0) {
170             }
171              
172             elsif (__PACKAGE__ =~ / \b Eusascii \z/oxms) {
173             %range_tr = (
174             1 => [ [0x00..0xFF],
175             ],
176             );
177             }
178              
179             else {
180             croak "Don't know my package name '@{[__PACKAGE__]}'";
181             }
182              
183             #
184             # @ARGV wildcard globbing
185             #
186             sub import {
187              
188 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
189 0         0 my @argv = ();
190 0         0 for (@ARGV) {
191              
192             # has space
193 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
194 0 0       0 if (my @glob = Eusascii::glob(qq{"$_"})) {
195 0         0 push @argv, @glob;
196             }
197             else {
198 0         0 push @argv, $_;
199             }
200             }
201              
202             # has wildcard metachar
203             elsif (/\A (?:$q_char)*? [*?] /oxms) {
204 0 0       0 if (my @glob = Eusascii::glob($_)) {
205 0         0 push @argv, @glob;
206             }
207             else {
208 0         0 push @argv, $_;
209             }
210             }
211              
212             # no wildcard globbing
213             else {
214 0         0 push @argv, $_;
215             }
216             }
217 0         0 @ARGV = @argv;
218             }
219              
220 0         0 *Char::ord = \&USASCII::ord;
221 0         0 *Char::ord_ = \&USASCII::ord_;
222 0         0 *Char::reverse = \&USASCII::reverse;
223 0         0 *Char::getc = \&USASCII::getc;
224 0         0 *Char::length = \&USASCII::length;
225 0         0 *Char::substr = \&USASCII::substr;
226 0         0 *Char::index = \&USASCII::index;
227 0         0 *Char::rindex = \&USASCII::rindex;
228 0         0 *Char::eval = \&USASCII::eval;
229 0         0 *Char::escape = \&USASCII::escape;
230 0         0 *Char::escape_token = \&USASCII::escape_token;
231 0         0 *Char::escape_script = \&USASCII::escape_script;
232             }
233              
234             # P.230 Care with Prototypes
235             # in Chapter 6: Subroutines
236             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
237             #
238             # If you aren't careful, you can get yourself into trouble with prototypes.
239             # But if you are careful, you can do a lot of neat things with them. This is
240             # all very powerful, of course, and should only be used in moderation to make
241             # the world a better place.
242              
243             # P.332 Care with Prototypes
244             # in Chapter 7: Subroutines
245             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
246             #
247             # If you aren't careful, you can get yourself into trouble with prototypes.
248             # But if you are careful, you can do a lot of neat things with them. This is
249             # all very powerful, of course, and should only be used in moderation to make
250             # the world a better place.
251              
252             #
253             # Prototypes of subroutines
254             #
255       0     sub unimport {}
256             sub Eusascii::split(;$$$);
257             sub Eusascii::tr($$$$;$);
258             sub Eusascii::chop(@);
259             sub Eusascii::index($$;$);
260             sub Eusascii::rindex($$;$);
261             sub Eusascii::lcfirst(@);
262             sub Eusascii::lcfirst_();
263             sub Eusascii::lc(@);
264             sub Eusascii::lc_();
265             sub Eusascii::ucfirst(@);
266             sub Eusascii::ucfirst_();
267             sub Eusascii::uc(@);
268             sub Eusascii::uc_();
269             sub Eusascii::fc(@);
270             sub Eusascii::fc_();
271             sub Eusascii::ignorecase;
272             sub Eusascii::classic_character_class;
273             sub Eusascii::capture;
274             sub Eusascii::chr(;$);
275             sub Eusascii::chr_();
276             sub Eusascii::glob($);
277             sub Eusascii::glob_();
278              
279             sub USASCII::ord(;$);
280             sub USASCII::ord_();
281             sub USASCII::reverse(@);
282             sub USASCII::getc(;*@);
283             sub USASCII::length(;$);
284             sub USASCII::substr($$;$$);
285             sub USASCII::index($$;$);
286             sub USASCII::rindex($$;$);
287             sub USASCII::escape(;$);
288              
289             #
290             # Regexp work
291             #
292 204         31705 use vars qw(
293             $re_a
294             $re_t
295             $re_n
296             $re_r
297 204     204   1406 );
  204         528  
298              
299             #
300             # Character class
301             #
302 204         2185281 use vars qw(
303             $dot
304             $dot_s
305             $eD
306             $eS
307             $eW
308             $eH
309             $eV
310             $eR
311             $eN
312             $not_alnum
313             $not_alpha
314             $not_ascii
315             $not_blank
316             $not_cntrl
317             $not_digit
318             $not_graph
319             $not_lower
320             $not_lower_i
321             $not_print
322             $not_punct
323             $not_space
324             $not_upper
325             $not_upper_i
326             $not_word
327             $not_xdigit
328             $eb
329             $eB
330 204     204   1459 );
  204         452  
331              
332             ${Eusascii::dot} = qr{(?>[^\x0A])};
333             ${Eusascii::dot_s} = qr{(?>[\x00-\xFF])};
334             ${Eusascii::eD} = qr{(?>[^0-9])};
335              
336             # Vertical tabs are now whitespace
337             # \s in a regex now matches a vertical tab in all circumstances.
338             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
339             # ${Eusascii::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
340             # ${Eusascii::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
341             ${Eusascii::eS} = qr{(?>[^\s])};
342              
343             ${Eusascii::eW} = qr{(?>[^0-9A-Z_a-z])};
344             ${Eusascii::eH} = qr{(?>[^\x09\x20])};
345             ${Eusascii::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
346             ${Eusascii::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
347             ${Eusascii::eN} = qr{(?>[^\x0A])};
348             ${Eusascii::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
349             ${Eusascii::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
350             ${Eusascii::not_ascii} = qr{(?>[^\x00-\x7F])};
351             ${Eusascii::not_blank} = qr{(?>[^\x09\x20])};
352             ${Eusascii::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
353             ${Eusascii::not_digit} = qr{(?>[^\x30-\x39])};
354             ${Eusascii::not_graph} = qr{(?>[^\x21-\x7F])};
355             ${Eusascii::not_lower} = qr{(?>[^\x61-\x7A])};
356             ${Eusascii::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
357             # ${Eusascii::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
358             ${Eusascii::not_print} = qr{(?>[^\x20-\x7F])};
359             ${Eusascii::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
360             ${Eusascii::not_space} = qr{(?>[^\s\x0B])};
361             ${Eusascii::not_upper} = qr{(?>[^\x41-\x5A])};
362             ${Eusascii::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
363             # ${Eusascii::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
364             ${Eusascii::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
365             ${Eusascii::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
366             ${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))};
367             ${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]))};
368              
369             # avoid: Name "Eusascii::foo" used only once: possible typo at here.
370             ${Eusascii::dot} = ${Eusascii::dot};
371             ${Eusascii::dot_s} = ${Eusascii::dot_s};
372             ${Eusascii::eD} = ${Eusascii::eD};
373             ${Eusascii::eS} = ${Eusascii::eS};
374             ${Eusascii::eW} = ${Eusascii::eW};
375             ${Eusascii::eH} = ${Eusascii::eH};
376             ${Eusascii::eV} = ${Eusascii::eV};
377             ${Eusascii::eR} = ${Eusascii::eR};
378             ${Eusascii::eN} = ${Eusascii::eN};
379             ${Eusascii::not_alnum} = ${Eusascii::not_alnum};
380             ${Eusascii::not_alpha} = ${Eusascii::not_alpha};
381             ${Eusascii::not_ascii} = ${Eusascii::not_ascii};
382             ${Eusascii::not_blank} = ${Eusascii::not_blank};
383             ${Eusascii::not_cntrl} = ${Eusascii::not_cntrl};
384             ${Eusascii::not_digit} = ${Eusascii::not_digit};
385             ${Eusascii::not_graph} = ${Eusascii::not_graph};
386             ${Eusascii::not_lower} = ${Eusascii::not_lower};
387             ${Eusascii::not_lower_i} = ${Eusascii::not_lower_i};
388             ${Eusascii::not_print} = ${Eusascii::not_print};
389             ${Eusascii::not_punct} = ${Eusascii::not_punct};
390             ${Eusascii::not_space} = ${Eusascii::not_space};
391             ${Eusascii::not_upper} = ${Eusascii::not_upper};
392             ${Eusascii::not_upper_i} = ${Eusascii::not_upper_i};
393             ${Eusascii::not_word} = ${Eusascii::not_word};
394             ${Eusascii::not_xdigit} = ${Eusascii::not_xdigit};
395             ${Eusascii::eb} = ${Eusascii::eb};
396             ${Eusascii::eB} = ${Eusascii::eB};
397              
398             #
399             # US-ASCII split
400             #
401             sub Eusascii::split(;$$$) {
402              
403             # P.794 29.2.161. split
404             # in Chapter 29: Functions
405             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
406              
407             # P.951 split
408             # in Chapter 27: Functions
409             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
410              
411 0     0 0 0 my $pattern = $_[0];
412 0         0 my $string = $_[1];
413 0         0 my $limit = $_[2];
414              
415             # if $pattern is also omitted or is the literal space, " "
416 0 0       0 if (not defined $pattern) {
417 0         0 $pattern = ' ';
418             }
419              
420             # if $string is omitted, the function splits the $_ string
421 0 0       0 if (not defined $string) {
422 0 0       0 if (defined $_) {
423 0         0 $string = $_;
424             }
425             else {
426 0         0 $string = '';
427             }
428             }
429              
430 0         0 my @split = ();
431              
432             # when string is empty
433 0 0       0 if ($string eq '') {
    0          
434              
435             # resulting list value in list context
436 0 0       0 if (wantarray) {
437 0         0 return @split;
438             }
439              
440             # count of substrings in scalar context
441             else {
442 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
443 0         0 @_ = @split;
444 0         0 return scalar @_;
445             }
446             }
447              
448             # split's first argument is more consistently interpreted
449             #
450             # After some changes earlier in v5.17, split's behavior has been simplified:
451             # if the PATTERN argument evaluates to a string containing one space, it is
452             # treated the way that a literal string containing one space once was.
453             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
454              
455             # if $pattern is also omitted or is the literal space, " ", the function splits
456             # on whitespace, /\s+/, after skipping any leading whitespace
457             # (and so on)
458              
459             elsif ($pattern eq ' ') {
460 0 0       0 if (not defined $limit) {
461 0         0 return CORE::split(' ', $string);
462             }
463             else {
464 0         0 return CORE::split(' ', $string, $limit);
465             }
466             }
467              
468             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
469 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
470              
471             # a pattern capable of matching either the null string or something longer than the
472             # null string will split the value of $string into separate characters wherever it
473             # matches the null string between characters
474             # (and so on)
475              
476 0 0       0 if ('' =~ / \A $pattern \z /xms) {
477 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
478 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
479              
480             # P.1024 Appendix W.10 Multibyte Processing
481             # of ISBN 1-56592-224-7 CJKV Information Processing
482             # (and so on)
483              
484             # the //m modifier is assumed when you split on the pattern /^/
485             # (and so on)
486              
487             # V
488 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
489              
490             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
491             # is included in the resulting list, interspersed with the fields that are ordinarily returned
492             # (and so on)
493              
494 0         0 local $@;
495 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
496 0         0 push @split, CORE::eval('$' . $digit);
497             }
498             }
499             }
500              
501             else {
502 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
503              
504             # V
505 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
506 0         0 local $@;
507 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
508 0         0 push @split, CORE::eval('$' . $digit);
509             }
510             }
511             }
512             }
513              
514             elsif ($limit > 0) {
515 0 0       0 if ('' =~ / \A $pattern \z /xms) {
516 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
517 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
518              
519             # V
520 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
521 0         0 local $@;
522 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
523 0         0 push @split, CORE::eval('$' . $digit);
524             }
525             }
526             }
527             }
528             else {
529 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
530 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
531              
532             # V
533 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
534 0         0 local $@;
535 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
536 0         0 push @split, CORE::eval('$' . $digit);
537             }
538             }
539             }
540             }
541             }
542              
543 0 0       0 if (CORE::length($string) > 0) {
544 0         0 push @split, $string;
545             }
546              
547             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
548 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
549 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
550 0         0 pop @split;
551             }
552             }
553              
554             # resulting list value in list context
555 0 0       0 if (wantarray) {
556 0         0 return @split;
557             }
558              
559             # count of substrings in scalar context
560             else {
561 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
562 0         0 @_ = @split;
563 0         0 return scalar @_;
564             }
565             }
566              
567             #
568             # get last subexpression offsets
569             #
570             sub _last_subexpression_offsets {
571 0     0   0 my $pattern = $_[0];
572              
573             # remove comment
574 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
575              
576 0         0 my $modifier = '';
577 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
578 0         0 $modifier = $1;
579 0         0 $modifier =~ s/-[A-Za-z]*//;
580             }
581              
582             # with /x modifier
583 0         0 my @char = ();
584 0 0       0 if ($modifier =~ /x/oxms) {
585 0         0 @char = $pattern =~ /\G((?>
586             [^\\\#\[\(] |
587             \\ $q_char |
588             \# (?>[^\n]*) $ |
589             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
590             \(\? |
591             $q_char
592             ))/oxmsg;
593             }
594              
595             # without /x modifier
596             else {
597 0         0 @char = $pattern =~ /\G((?>
598             [^\\\[\(] |
599             \\ $q_char |
600             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
601             \(\? |
602             $q_char
603             ))/oxmsg;
604             }
605              
606 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
607             }
608              
609             #
610             # US-ASCII transliteration (tr///)
611             #
612             sub Eusascii::tr($$$$;$) {
613              
614 0     0 0 0 my $bind_operator = $_[1];
615 0         0 my $searchlist = $_[2];
616 0         0 my $replacementlist = $_[3];
617 0   0     0 my $modifier = $_[4] || '';
618              
619 0 0       0 if ($modifier =~ /r/oxms) {
620 0 0       0 if ($bind_operator =~ / !~ /oxms) {
621 0         0 croak "Using !~ with tr///r doesn't make sense";
622             }
623             }
624              
625 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
626 0         0 my @searchlist = _charlist_tr($searchlist);
627 0         0 my @replacementlist = _charlist_tr($replacementlist);
628              
629 0         0 my %tr = ();
630 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
631 0 0       0 if (not exists $tr{$searchlist[$i]}) {
632 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
633 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
634             }
635             elsif ($modifier =~ /d/oxms) {
636 0         0 $tr{$searchlist[$i]} = '';
637             }
638             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
639 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
640             }
641             else {
642 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
643             }
644             }
645             }
646              
647 0         0 my $tr = 0;
648 0         0 my $replaced = '';
649 0 0       0 if ($modifier =~ /c/oxms) {
650 0         0 while (defined(my $char = shift @char)) {
651 0 0       0 if (not exists $tr{$char}) {
652 0 0       0 if (defined $replacementlist[0]) {
653 0         0 $replaced .= $replacementlist[0];
654             }
655 0         0 $tr++;
656 0 0       0 if ($modifier =~ /s/oxms) {
657 0   0     0 while (@char and (not exists $tr{$char[0]})) {
658 0         0 shift @char;
659 0         0 $tr++;
660             }
661             }
662             }
663             else {
664 0         0 $replaced .= $char;
665             }
666             }
667             }
668             else {
669 0         0 while (defined(my $char = shift @char)) {
670 0 0       0 if (exists $tr{$char}) {
671 0         0 $replaced .= $tr{$char};
672 0         0 $tr++;
673 0 0       0 if ($modifier =~ /s/oxms) {
674 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
675 0         0 shift @char;
676 0         0 $tr++;
677             }
678             }
679             }
680             else {
681 0         0 $replaced .= $char;
682             }
683             }
684             }
685              
686 0 0       0 if ($modifier =~ /r/oxms) {
687 0         0 return $replaced;
688             }
689             else {
690 0         0 $_[0] = $replaced;
691 0 0       0 if ($bind_operator =~ / !~ /oxms) {
692 0         0 return not $tr;
693             }
694             else {
695 0         0 return $tr;
696             }
697             }
698             }
699              
700             #
701             # US-ASCII chop
702             #
703             sub Eusascii::chop(@) {
704              
705 0     0 0 0 my $chop;
706 0 0       0 if (@_ == 0) {
707 0         0 my @char = /\G (?>$q_char) /oxmsg;
708 0         0 $chop = pop @char;
709 0         0 $_ = join '', @char;
710             }
711             else {
712 0         0 for (@_) {
713 0         0 my @char = /\G (?>$q_char) /oxmsg;
714 0         0 $chop = pop @char;
715 0         0 $_ = join '', @char;
716             }
717             }
718 0         0 return $chop;
719             }
720              
721             #
722             # US-ASCII index by octet
723             #
724             sub Eusascii::index($$;$) {
725              
726 0     0 1 0 my($str,$substr,$position) = @_;
727 0   0     0 $position ||= 0;
728 0         0 my $pos = 0;
729              
730 0         0 while ($pos < CORE::length($str)) {
731 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
732 0 0       0 if ($pos >= $position) {
733 0         0 return $pos;
734             }
735             }
736 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
737 0         0 $pos += CORE::length($1);
738             }
739             else {
740 0         0 $pos += 1;
741             }
742             }
743 0         0 return -1;
744             }
745              
746             #
747             # US-ASCII reverse index
748             #
749             sub Eusascii::rindex($$;$) {
750              
751 0     0 0 0 my($str,$substr,$position) = @_;
752 0   0     0 $position ||= CORE::length($str) - 1;
753 0         0 my $pos = 0;
754 0         0 my $rindex = -1;
755              
756 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
757 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
758 0         0 $rindex = $pos;
759             }
760 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
761 0         0 $pos += CORE::length($1);
762             }
763             else {
764 0         0 $pos += 1;
765             }
766             }
767 0         0 return $rindex;
768             }
769              
770             #
771             # US-ASCII lower case first with parameter
772             #
773             sub Eusascii::lcfirst(@) {
774 0 0   0 0 0 if (@_) {
775 0         0 my $s = shift @_;
776 0 0 0     0 if (@_ and wantarray) {
777 0         0 return Eusascii::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
778             }
779             else {
780 0         0 return Eusascii::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
781             }
782             }
783             else {
784 0         0 return Eusascii::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
785             }
786             }
787              
788             #
789             # US-ASCII lower case first without parameter
790             #
791             sub Eusascii::lcfirst_() {
792 0     0 0 0 return Eusascii::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
793             }
794              
795             #
796             # US-ASCII lower case with parameter
797             #
798             sub Eusascii::lc(@) {
799 0 0   0 0 0 if (@_) {
800 0         0 my $s = shift @_;
801 0 0 0     0 if (@_ and wantarray) {
802 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
803             }
804             else {
805 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
806             }
807             }
808             else {
809 0         0 return Eusascii::lc_();
810             }
811             }
812              
813             #
814             # US-ASCII lower case without parameter
815             #
816             sub Eusascii::lc_() {
817 0     0 0 0 my $s = $_;
818 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
819             }
820              
821             #
822             # US-ASCII upper case first with parameter
823             #
824             sub Eusascii::ucfirst(@) {
825 0 0   0 0 0 if (@_) {
826 0         0 my $s = shift @_;
827 0 0 0     0 if (@_ and wantarray) {
828 0         0 return Eusascii::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
829             }
830             else {
831 0         0 return Eusascii::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
832             }
833             }
834             else {
835 0         0 return Eusascii::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
836             }
837             }
838              
839             #
840             # US-ASCII upper case first without parameter
841             #
842             sub Eusascii::ucfirst_() {
843 0     0 0 0 return Eusascii::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
844             }
845              
846             #
847             # US-ASCII upper case with parameter
848             #
849             sub Eusascii::uc(@) {
850 0 50   114 0 0 if (@_) {
851 114         182 my $s = shift @_;
852 114 50 33     134 if (@_ and wantarray) {
853 114 0       202 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
854             }
855             else {
856 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  114         374  
857             }
858             }
859             else {
860 114         409 return Eusascii::uc_();
861             }
862             }
863              
864             #
865             # US-ASCII upper case without parameter
866             #
867             sub Eusascii::uc_() {
868 0     0 0 0 my $s = $_;
869 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
870             }
871              
872             #
873             # US-ASCII fold case with parameter
874             #
875             sub Eusascii::fc(@) {
876 0 50   137 0 0 if (@_) {
877 137         204 my $s = shift @_;
878 137 50 33     160 if (@_ and wantarray) {
879 137 0       245 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
880             }
881             else {
882 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  137         361  
883             }
884             }
885             else {
886 137         969 return Eusascii::fc_();
887             }
888             }
889              
890             #
891             # US-ASCII fold case without parameter
892             #
893             sub Eusascii::fc_() {
894 0     0 0 0 my $s = $_;
895 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
896             }
897              
898             #
899             # US-ASCII regexp capture
900             #
901             {
902             sub Eusascii::capture {
903 0     0 1 0 return $_[0];
904             }
905             }
906              
907             #
908             # US-ASCII regexp ignore case modifier
909             #
910             sub Eusascii::ignorecase {
911              
912 0     0 0 0 my @string = @_;
913 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
914              
915             # ignore case of $scalar or @array
916 0         0 for my $string (@string) {
917              
918             # split regexp
919 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
920              
921             # unescape character
922 0         0 for (my $i=0; $i <= $#char; $i++) {
923 0 0       0 next if not defined $char[$i];
924              
925             # open character class [...]
926 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
927 0         0 my $left = $i;
928              
929             # [] make die "unmatched [] in regexp ...\n"
930              
931 0 0       0 if ($char[$i+1] eq ']') {
932 0         0 $i++;
933             }
934              
935 0         0 while (1) {
936 0 0       0 if (++$i > $#char) {
937 0         0 croak "Unmatched [] in regexp";
938             }
939 0 0       0 if ($char[$i] eq ']') {
940 0         0 my $right = $i;
941 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
942              
943             # escape character
944 0         0 for my $char (@charlist) {
945 0 0       0 if (0) {
946             }
947              
948 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
949 0         0 $char = '\\' . $char;
950             }
951             }
952              
953             # [...]
954 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
955              
956 0         0 $i = $left;
957 0         0 last;
958             }
959             }
960             }
961              
962             # open character class [^...]
963             elsif ($char[$i] eq '[^') {
964 0         0 my $left = $i;
965              
966             # [^] make die "unmatched [] in regexp ...\n"
967              
968 0 0       0 if ($char[$i+1] eq ']') {
969 0         0 $i++;
970             }
971              
972 0         0 while (1) {
973 0 0       0 if (++$i > $#char) {
974 0         0 croak "Unmatched [] in regexp";
975             }
976 0 0       0 if ($char[$i] eq ']') {
977 0         0 my $right = $i;
978 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
979              
980             # escape character
981 0         0 for my $char (@charlist) {
982 0 0       0 if (0) {
983             }
984              
985 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
986 0         0 $char = '\\' . $char;
987             }
988             }
989              
990             # [^...]
991 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
992              
993 0         0 $i = $left;
994 0         0 last;
995             }
996             }
997             }
998              
999             # rewrite classic character class or escape character
1000             elsif (my $char = classic_character_class($char[$i])) {
1001 0         0 $char[$i] = $char;
1002             }
1003              
1004             # with /i modifier
1005             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1006 0         0 my $uc = Eusascii::uc($char[$i]);
1007 0         0 my $fc = Eusascii::fc($char[$i]);
1008 0 0       0 if ($uc ne $fc) {
1009 0 0       0 if (CORE::length($fc) == 1) {
1010 0         0 $char[$i] = '[' . $uc . $fc . ']';
1011             }
1012             else {
1013 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1014             }
1015             }
1016             }
1017             }
1018              
1019             # characterize
1020 0         0 for (my $i=0; $i <= $#char; $i++) {
1021 0 0       0 next if not defined $char[$i];
1022              
1023 0 0       0 if (0) {
1024             }
1025              
1026             # quote character before ? + * {
1027 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1028 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1029 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1030             }
1031             }
1032             }
1033              
1034 0         0 $string = join '', @char;
1035             }
1036              
1037             # make regexp string
1038 0         0 return @string;
1039             }
1040              
1041             #
1042             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1043             #
1044             sub Eusascii::classic_character_class {
1045 0     1827 0 0 my($char) = @_;
1046              
1047             return {
1048             '\D' => '${Eusascii::eD}',
1049             '\S' => '${Eusascii::eS}',
1050             '\W' => '${Eusascii::eW}',
1051             '\d' => '[0-9]',
1052              
1053             # Before Perl 5.6, \s only matched the five whitespace characters
1054             # tab, newline, form-feed, carriage return, and the space character
1055             # itself, which, taken together, is the character class [\t\n\f\r ].
1056              
1057             # Vertical tabs are now whitespace
1058             # \s in a regex now matches a vertical tab in all circumstances.
1059             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1060             # \t \n \v \f \r space
1061             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1062             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1063             '\s' => '\s',
1064              
1065             '\w' => '[0-9A-Z_a-z]',
1066             '\C' => '[\x00-\xFF]',
1067             '\X' => 'X',
1068              
1069             # \h \v \H \V
1070              
1071             # P.114 Character Class Shortcuts
1072             # in Chapter 7: In the World of Regular Expressions
1073             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1074              
1075             # P.357 13.2.3 Whitespace
1076             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1077             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1078             #
1079             # 0x00009 CHARACTER TABULATION h s
1080             # 0x0000a LINE FEED (LF) vs
1081             # 0x0000b LINE TABULATION v
1082             # 0x0000c FORM FEED (FF) vs
1083             # 0x0000d CARRIAGE RETURN (CR) vs
1084             # 0x00020 SPACE h s
1085              
1086             # P.196 Table 5-9. Alphanumeric regex metasymbols
1087             # in Chapter 5. Pattern Matching
1088             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1089              
1090             # (and so on)
1091              
1092             '\H' => '${Eusascii::eH}',
1093             '\V' => '${Eusascii::eV}',
1094             '\h' => '[\x09\x20]',
1095             '\v' => '[\x0A\x0B\x0C\x0D]',
1096             '\R' => '${Eusascii::eR}',
1097              
1098             # \N
1099             #
1100             # http://perldoc.perl.org/perlre.html
1101             # Character Classes and other Special Escapes
1102             # Any character but \n (experimental). Not affected by /s modifier
1103              
1104             '\N' => '${Eusascii::eN}',
1105              
1106             # \b \B
1107              
1108             # P.180 Boundaries: The \b and \B Assertions
1109             # in Chapter 5: Pattern Matching
1110             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1111              
1112             # P.219 Boundaries: The \b and \B Assertions
1113             # in Chapter 5: Pattern Matching
1114             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1115              
1116             # \b really means (?:(?<=\w)(?!\w)|(?
1117             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1118             '\b' => '${Eusascii::eb}',
1119              
1120             # \B really means (?:(?<=\w)(?=\w)|(?
1121             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1122             '\B' => '${Eusascii::eB}',
1123              
1124 1827   100     3106 }->{$char} || '';
1125             }
1126              
1127             #
1128             # prepare US-ASCII characters per length
1129             #
1130              
1131             # 1 octet characters
1132             my @chars1 = ();
1133             sub chars1 {
1134 1827 0   0 0 74141 if (@chars1) {
1135 0         0 return @chars1;
1136             }
1137 0 0       0 if (exists $range_tr{1}) {
1138 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1139 0         0 while (my @range = splice(@ranges,0,1)) {
1140 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1141 0         0 push @chars1, pack 'C', $oct0;
1142             }
1143             }
1144             }
1145 0         0 return @chars1;
1146             }
1147              
1148             # 2 octets characters
1149             my @chars2 = ();
1150             sub chars2 {
1151 0 0   0 0 0 if (@chars2) {
1152 0         0 return @chars2;
1153             }
1154 0 0       0 if (exists $range_tr{2}) {
1155 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1156 0         0 while (my @range = splice(@ranges,0,2)) {
1157 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1158 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1159 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1160             }
1161             }
1162             }
1163             }
1164 0         0 return @chars2;
1165             }
1166              
1167             # 3 octets characters
1168             my @chars3 = ();
1169             sub chars3 {
1170 0 0   0 0 0 if (@chars3) {
1171 0         0 return @chars3;
1172             }
1173 0 0       0 if (exists $range_tr{3}) {
1174 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1175 0         0 while (my @range = splice(@ranges,0,3)) {
1176 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1177 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1178 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1179 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1180             }
1181             }
1182             }
1183             }
1184             }
1185 0         0 return @chars3;
1186             }
1187              
1188             # 4 octets characters
1189             my @chars4 = ();
1190             sub chars4 {
1191 0 0   0 0 0 if (@chars4) {
1192 0         0 return @chars4;
1193             }
1194 0 0       0 if (exists $range_tr{4}) {
1195 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1196 0         0 while (my @range = splice(@ranges,0,4)) {
1197 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1198 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1199 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1200 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1201 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1202             }
1203             }
1204             }
1205             }
1206             }
1207             }
1208 0         0 return @chars4;
1209             }
1210              
1211             #
1212             # US-ASCII open character list for tr
1213             #
1214             sub _charlist_tr {
1215              
1216 0     0   0 local $_ = shift @_;
1217              
1218             # unescape character
1219 0         0 my @char = ();
1220 0         0 while (not /\G \z/oxmsgc) {
1221 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1222 0         0 push @char, '\-';
1223             }
1224             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1225 0         0 push @char, CORE::chr(oct $1);
1226             }
1227             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1228 0         0 push @char, CORE::chr(hex $1);
1229             }
1230             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1231 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1232             }
1233             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1234             push @char, {
1235             '\0' => "\0",
1236             '\n' => "\n",
1237             '\r' => "\r",
1238             '\t' => "\t",
1239             '\f' => "\f",
1240             '\b' => "\x08", # \b means backspace in character class
1241             '\a' => "\a",
1242             '\e' => "\e",
1243 0         0 }->{$1};
1244             }
1245             elsif (/\G \\ ($q_char) /oxmsgc) {
1246 0         0 push @char, $1;
1247             }
1248             elsif (/\G ($q_char) /oxmsgc) {
1249 0         0 push @char, $1;
1250             }
1251             }
1252              
1253             # join separated multiple-octet
1254 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1255              
1256             # unescape '-'
1257 0         0 my @i = ();
1258 0         0 for my $i (0 .. $#char) {
1259 0 0       0 if ($char[$i] eq '\-') {
    0          
1260 0         0 $char[$i] = '-';
1261             }
1262             elsif ($char[$i] eq '-') {
1263 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1264 0         0 push @i, $i;
1265             }
1266             }
1267             }
1268              
1269             # open character list (reverse for splice)
1270 0         0 for my $i (CORE::reverse @i) {
1271 0         0 my @range = ();
1272              
1273             # range error
1274 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1275 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1276             }
1277              
1278             # range of multiple-octet code
1279 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1280 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1281 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1282             }
1283             elsif (CORE::length($char[$i+1]) == 2) {
1284 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1285 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1286             }
1287             elsif (CORE::length($char[$i+1]) == 3) {
1288 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1289 0         0 push @range, chars2();
1290 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1291             }
1292             elsif (CORE::length($char[$i+1]) == 4) {
1293 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1294 0         0 push @range, chars2();
1295 0         0 push @range, chars3();
1296 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1297             }
1298             else {
1299 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1300             }
1301             }
1302             elsif (CORE::length($char[$i-1]) == 2) {
1303 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1304 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1305             }
1306             elsif (CORE::length($char[$i+1]) == 3) {
1307 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1308 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1309             }
1310             elsif (CORE::length($char[$i+1]) == 4) {
1311 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1312 0         0 push @range, chars3();
1313 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1314             }
1315             else {
1316 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1317             }
1318             }
1319             elsif (CORE::length($char[$i-1]) == 3) {
1320 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1321 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1322             }
1323             elsif (CORE::length($char[$i+1]) == 4) {
1324 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1325 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1326             }
1327             else {
1328 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1329             }
1330             }
1331             elsif (CORE::length($char[$i-1]) == 4) {
1332 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1333 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1334             }
1335             else {
1336 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1337             }
1338             }
1339             else {
1340 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1341             }
1342              
1343 0         0 splice @char, $i-1, 3, @range;
1344             }
1345              
1346 0         0 return @char;
1347             }
1348              
1349             #
1350             # US-ASCII open character class
1351             #
1352             sub _cc {
1353 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1354 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1355             }
1356             elsif (scalar(@_) == 1) {
1357 0         0 return sprintf('\x%02X',$_[0]);
1358             }
1359             elsif (scalar(@_) == 2) {
1360 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1361 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1362             }
1363             elsif ($_[0] == $_[1]) {
1364 0         0 return sprintf('\x%02X',$_[0]);
1365             }
1366             elsif (($_[0]+1) == $_[1]) {
1367 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1368             }
1369             else {
1370 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1371             }
1372             }
1373             else {
1374 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1375             }
1376             }
1377              
1378             #
1379             # US-ASCII octet range
1380             #
1381             sub _octets {
1382 0     182   0 my $length = shift @_;
1383              
1384 182 50       315 if ($length == 1) {
1385 182         387 my($a1) = unpack 'C', $_[0];
1386 182         481 my($z1) = unpack 'C', $_[1];
1387              
1388 182 50       385 if ($a1 > $z1) {
1389 182         354 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1390             }
1391              
1392 0 50       0 if ($a1 == $z1) {
    50          
1393 182         414 return sprintf('\x%02X',$a1);
1394             }
1395             elsif (($a1+1) == $z1) {
1396 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1397             }
1398             else {
1399 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1400             }
1401             }
1402             else {
1403 182         1657 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1404             }
1405             }
1406              
1407             #
1408             # US-ASCII range regexp
1409             #
1410             sub _range_regexp {
1411 0     182   0 my($length,$first,$last) = @_;
1412              
1413 182         362 my @range_regexp = ();
1414 182 50       307 if (not exists $range_tr{$length}) {
1415 182         499 return @range_regexp;
1416             }
1417              
1418 0         0 my @ranges = @{ $range_tr{$length} };
  182         357  
1419 182         399 while (my @range = splice(@ranges,0,$length)) {
1420 182         553 my $min = '';
1421 182         272 my $max = '';
1422 182         229 for (my $i=0; $i < $length; $i++) {
1423 182         467 $min .= pack 'C', $range[$i][0];
1424 182         637 $max .= pack 'C', $range[$i][-1];
1425             }
1426              
1427             # min___max
1428             # FIRST_____________LAST
1429             # (nothing)
1430              
1431 182 50 33     449 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1432             }
1433              
1434             # **********
1435             # min_________max
1436             # FIRST_____________LAST
1437             # **********
1438              
1439             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1440 182         1850 push @range_regexp, _octets($length,$first,$max,$min,$max);
1441             }
1442              
1443             # **********************
1444             # min________________max
1445             # FIRST_____________LAST
1446             # **********************
1447              
1448             elsif (($min eq $first) and ($max eq $last)) {
1449 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1450             }
1451              
1452             # *********
1453             # min___max
1454             # FIRST_____________LAST
1455             # *********
1456              
1457             elsif (($first le $min) and ($max le $last)) {
1458 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1459             }
1460              
1461             # **********************
1462             # min__________________________max
1463             # FIRST_____________LAST
1464             # **********************
1465              
1466             elsif (($min le $first) and ($last le $max)) {
1467 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1468             }
1469              
1470             # *********
1471             # min________max
1472             # FIRST_____________LAST
1473             # *********
1474              
1475             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1476 182         462 push @range_regexp, _octets($length,$min,$last,$min,$max);
1477             }
1478              
1479             # min___max
1480             # FIRST_____________LAST
1481             # (nothing)
1482              
1483             elsif ($last lt $min) {
1484             }
1485              
1486             else {
1487 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1488             }
1489             }
1490              
1491 0         0 return @range_regexp;
1492             }
1493              
1494             #
1495             # US-ASCII open character list for qr and not qr
1496             #
1497             sub _charlist {
1498              
1499 182     346   418 my $modifier = pop @_;
1500 346         741 my @char = @_;
1501              
1502 346 100       833 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1503              
1504             # unescape character
1505 346         1480 for (my $i=0; $i <= $#char; $i++) {
1506              
1507             # escape - to ...
1508 346 100 100     1651 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1509 1101 100 100     8404 if ((0 < $i) and ($i < $#char)) {
1510 206         744 $char[$i] = '...';
1511             }
1512             }
1513              
1514             # octal escape sequence
1515             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1516 182         394 $char[$i] = octchr($1);
1517             }
1518              
1519             # hexadecimal escape sequence
1520             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1521 0         0 $char[$i] = hexchr($1);
1522             }
1523              
1524             # \b{...} --> b\{...}
1525             # \B{...} --> B\{...}
1526             # \N{CHARNAME} --> N\{CHARNAME}
1527             # \p{PROPERTY} --> p\{PROPERTY}
1528             # \P{PROPERTY} --> P\{PROPERTY}
1529             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1530 0         0 $char[$i] = $1 . '\\' . $2;
1531             }
1532              
1533             # \p, \P, \X --> p, P, X
1534             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1535 0         0 $char[$i] = $1;
1536             }
1537              
1538             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1539 0         0 $char[$i] = CORE::chr oct $1;
1540             }
1541             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1542 0         0 $char[$i] = CORE::chr hex $1;
1543             }
1544             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1545 22         107 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1546             }
1547             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1548             $char[$i] = {
1549             '\0' => "\0",
1550             '\n' => "\n",
1551             '\r' => "\r",
1552             '\t' => "\t",
1553             '\f' => "\f",
1554             '\b' => "\x08", # \b means backspace in character class
1555             '\a' => "\a",
1556             '\e' => "\e",
1557             '\d' => '[0-9]',
1558              
1559             # Vertical tabs are now whitespace
1560             # \s in a regex now matches a vertical tab in all circumstances.
1561             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1562             # \t \n \v \f \r space
1563             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1564             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1565             '\s' => '\s',
1566              
1567             '\w' => '[0-9A-Z_a-z]',
1568             '\D' => '${Eusascii::eD}',
1569             '\S' => '${Eusascii::eS}',
1570             '\W' => '${Eusascii::eW}',
1571              
1572             '\H' => '${Eusascii::eH}',
1573             '\V' => '${Eusascii::eV}',
1574             '\h' => '[\x09\x20]',
1575             '\v' => '[\x0A\x0B\x0C\x0D]',
1576             '\R' => '${Eusascii::eR}',
1577              
1578 0         0 }->{$1};
1579             }
1580              
1581             # POSIX-style character classes
1582             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1583             $char[$i] = {
1584              
1585             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1586             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1587             '[:^lower:]' => '${Eusascii::not_lower_i}',
1588             '[:^upper:]' => '${Eusascii::not_upper_i}',
1589              
1590 25         612 }->{$1};
1591             }
1592             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1593             $char[$i] = {
1594              
1595             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1596             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1597             '[:ascii:]' => '[\x00-\x7F]',
1598             '[:blank:]' => '[\x09\x20]',
1599             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1600             '[:digit:]' => '[\x30-\x39]',
1601             '[:graph:]' => '[\x21-\x7F]',
1602             '[:lower:]' => '[\x61-\x7A]',
1603             '[:print:]' => '[\x20-\x7F]',
1604             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1605              
1606             # P.174 POSIX-Style Character Classes
1607             # in Chapter 5: Pattern Matching
1608             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1609              
1610             # P.311 11.2.4 Character Classes and other Special Escapes
1611             # in Chapter 11: perlre: Perl regular expressions
1612             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1613              
1614             # P.210 POSIX-Style Character Classes
1615             # in Chapter 5: Pattern Matching
1616             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1617              
1618             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1619              
1620             '[:upper:]' => '[\x41-\x5A]',
1621             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1622             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1623             '[:^alnum:]' => '${Eusascii::not_alnum}',
1624             '[:^alpha:]' => '${Eusascii::not_alpha}',
1625             '[:^ascii:]' => '${Eusascii::not_ascii}',
1626             '[:^blank:]' => '${Eusascii::not_blank}',
1627             '[:^cntrl:]' => '${Eusascii::not_cntrl}',
1628             '[:^digit:]' => '${Eusascii::not_digit}',
1629             '[:^graph:]' => '${Eusascii::not_graph}',
1630             '[:^lower:]' => '${Eusascii::not_lower}',
1631             '[:^print:]' => '${Eusascii::not_print}',
1632             '[:^punct:]' => '${Eusascii::not_punct}',
1633             '[:^space:]' => '${Eusascii::not_space}',
1634             '[:^upper:]' => '${Eusascii::not_upper}',
1635             '[:^word:]' => '${Eusascii::not_word}',
1636             '[:^xdigit:]' => '${Eusascii::not_xdigit}',
1637              
1638 8         66 }->{$1};
1639             }
1640             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1641 70         1720 $char[$i] = $1;
1642             }
1643             }
1644              
1645             # open character list
1646 7         32 my @singleoctet = ();
1647 346         613 my @multipleoctet = ();
1648 346         467 for (my $i=0; $i <= $#char; ) {
1649              
1650             # escaped -
1651 346 100 100     785 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1652 919         4177 $i += 1;
1653 182         254 next;
1654             }
1655              
1656             # make range regexp
1657             elsif ($char[$i] eq '...') {
1658              
1659             # range error
1660 182 50       333 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1661 182         699 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1662             }
1663             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1664 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1665 182         478 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1666             }
1667             }
1668              
1669             # make range regexp per length
1670 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1671 182         505 my @regexp = ();
1672              
1673             # is first and last
1674 182 50 33     303 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1675 182         662 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1676             }
1677              
1678             # is first
1679             elsif ($length == CORE::length($char[$i-1])) {
1680 182         463 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1681             }
1682              
1683             # is inside in first and last
1684             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1685 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1686             }
1687              
1688             # is last
1689             elsif ($length == CORE::length($char[$i+1])) {
1690 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1691             }
1692              
1693             else {
1694 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1695             }
1696              
1697 0 50       0 if ($length == 1) {
1698 182         337 push @singleoctet, @regexp;
1699             }
1700             else {
1701 182         424 push @multipleoctet, @regexp;
1702             }
1703             }
1704              
1705 0         0 $i += 2;
1706             }
1707              
1708             # with /i modifier
1709             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1710 182 50       362 if ($modifier =~ /i/oxms) {
1711 469         743 my $uc = Eusascii::uc($char[$i]);
1712 0         0 my $fc = Eusascii::fc($char[$i]);
1713 0 0       0 if ($uc ne $fc) {
1714 0 0       0 if (CORE::length($fc) == 1) {
1715 0         0 push @singleoctet, $uc, $fc;
1716             }
1717             else {
1718 0         0 push @singleoctet, $uc;
1719 0         0 push @multipleoctet, $fc;
1720             }
1721             }
1722             else {
1723 0         0 push @singleoctet, $char[$i];
1724             }
1725             }
1726             else {
1727 0         0 push @singleoctet, $char[$i];
1728             }
1729 469         712 $i += 1;
1730             }
1731              
1732             # single character of single octet code
1733             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1734 469         884 push @singleoctet, "\t", "\x20";
1735 0         0 $i += 1;
1736             }
1737             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1738 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1739 0         0 $i += 1;
1740             }
1741             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1742 0         0 push @singleoctet, $char[$i];
1743 2         5 $i += 1;
1744             }
1745              
1746             # single character of multiple-octet code
1747             else {
1748 2         5 push @multipleoctet, $char[$i];
1749 84         158 $i += 1;
1750             }
1751             }
1752              
1753             # quote metachar
1754 84         173 for (@singleoctet) {
1755 346 50       687 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1756 653         3297 $_ = '-';
1757             }
1758             elsif (/\A \n \z/oxms) {
1759 0         0 $_ = '\n';
1760             }
1761             elsif (/\A \r \z/oxms) {
1762 8         22 $_ = '\r';
1763             }
1764             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1765 8         16 $_ = sprintf('\x%02X', CORE::ord $1);
1766             }
1767             elsif (/\A [\x00-\xFF] \z/oxms) {
1768 24         86 $_ = quotemeta $_;
1769             }
1770             }
1771              
1772             # return character list
1773 429         711 return \@singleoctet, \@multipleoctet;
1774             }
1775              
1776             #
1777             # US-ASCII octal escape sequence
1778             #
1779             sub octchr {
1780 346     5 0 1325 my($octdigit) = @_;
1781              
1782 5         14 my @binary = ();
1783 5         8 for my $octal (split(//,$octdigit)) {
1784             push @binary, {
1785             '0' => '000',
1786             '1' => '001',
1787             '2' => '010',
1788             '3' => '011',
1789             '4' => '100',
1790             '5' => '101',
1791             '6' => '110',
1792             '7' => '111',
1793 5         24 }->{$octal};
1794             }
1795 50         175 my $binary = join '', @binary;
1796              
1797             my $octchr = {
1798             # 1234567
1799             1 => pack('B*', "0000000$binary"),
1800             2 => pack('B*', "000000$binary"),
1801             3 => pack('B*', "00000$binary"),
1802             4 => pack('B*', "0000$binary"),
1803             5 => pack('B*', "000$binary"),
1804             6 => pack('B*', "00$binary"),
1805             7 => pack('B*', "0$binary"),
1806             0 => pack('B*', "$binary"),
1807              
1808 5         16 }->{CORE::length($binary) % 8};
1809              
1810 5         61 return $octchr;
1811             }
1812              
1813             #
1814             # US-ASCII hexadecimal escape sequence
1815             #
1816             sub hexchr {
1817 5     5 0 18 my($hexdigit) = @_;
1818              
1819             my $hexchr = {
1820             1 => pack('H*', "0$hexdigit"),
1821             0 => pack('H*', "$hexdigit"),
1822              
1823 5         14 }->{CORE::length($_[0]) % 2};
1824              
1825 5         43 return $hexchr;
1826             }
1827              
1828             #
1829             # US-ASCII open character list for qr
1830             #
1831             sub charlist_qr {
1832              
1833 5     302 0 18 my $modifier = pop @_;
1834 302         574 my @char = @_;
1835              
1836 302         784 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1837 302         850 my @singleoctet = @$singleoctet;
1838 302         670 my @multipleoctet = @$multipleoctet;
1839              
1840             # return character list
1841 302 100       513 if (scalar(@singleoctet) >= 1) {
1842              
1843             # with /i modifier
1844 302 100       756 if ($modifier =~ m/i/oxms) {
1845 224         504 my %singleoctet_ignorecase = ();
1846 10         15 for (@singleoctet) {
1847 10   66     15 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1848 10         45 for my $ord (hex($1) .. hex($2)) {
1849 10         33 my $char = CORE::chr($ord);
1850 30         46 my $uc = Eusascii::uc($char);
1851 30         46 my $fc = Eusascii::fc($char);
1852 30 50       48 if ($uc eq $fc) {
1853 30         44 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1854             }
1855             else {
1856 0 50       0 if (CORE::length($fc) == 1) {
1857 30         41 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1858 30         63 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1859             }
1860             else {
1861 30         89 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1862 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1863             }
1864             }
1865             }
1866             }
1867 0 50       0 if ($_ ne '') {
1868 10         27 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1869             }
1870             }
1871 0         0 my $i = 0;
1872 10         14 my @singleoctet_ignorecase = ();
1873 10         12 for my $ord (0 .. 255) {
1874 10 100       17 if (exists $singleoctet_ignorecase{$ord}) {
1875 2560         2843 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         54  
1876             }
1877             else {
1878 60         91 $i++;
1879             }
1880             }
1881 2500         2620 @singleoctet = ();
1882 10         17 for my $range (@singleoctet_ignorecase) {
1883 10 100       25 if (ref $range) {
1884 960 50       1557 if (scalar(@{$range}) == 1) {
  20 50       21  
1885 20         33 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1886             }
1887 0         0 elsif (scalar(@{$range}) == 2) {
1888 20         27 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1889             }
1890             else {
1891 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         21  
  20         27  
1892             }
1893             }
1894             }
1895             }
1896              
1897 20         91 my $not_anchor = '';
1898              
1899 224         329 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
1900             }
1901 224 100       679 if (scalar(@multipleoctet) >= 2) {
1902 302         624 return '(?:' . join('|', @multipleoctet) . ')';
1903             }
1904             else {
1905 6         32 return $multipleoctet[0];
1906             }
1907             }
1908              
1909             #
1910             # US-ASCII open character list for not qr
1911             #
1912             sub charlist_not_qr {
1913              
1914 296     44 0 1379 my $modifier = pop @_;
1915 44         89 my @char = @_;
1916              
1917 44         114 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1918 44         128 my @singleoctet = @$singleoctet;
1919 44         129 my @multipleoctet = @$multipleoctet;
1920              
1921             # with /i modifier
1922 44 100       182 if ($modifier =~ m/i/oxms) {
1923 44         243 my %singleoctet_ignorecase = ();
1924 10         17 for (@singleoctet) {
1925 10   66     17 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1926 10         58 for my $ord (hex($1) .. hex($2)) {
1927 10         37 my $char = CORE::chr($ord);
1928 30         49 my $uc = Eusascii::uc($char);
1929 30         47 my $fc = Eusascii::fc($char);
1930 30 50       59 if ($uc eq $fc) {
1931 30         51 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1932             }
1933             else {
1934 0 50       0 if (CORE::length($fc) == 1) {
1935 30         43 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1936 30         66 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1937             }
1938             else {
1939 30         89 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1940 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1941             }
1942             }
1943             }
1944             }
1945 0 50       0 if ($_ ne '') {
1946 10         29 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1947             }
1948             }
1949 0         0 my $i = 0;
1950 10         14 my @singleoctet_ignorecase = ();
1951 10         12 for my $ord (0 .. 255) {
1952 10 100       20 if (exists $singleoctet_ignorecase{$ord}) {
1953 2560         2887 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         57  
1954             }
1955             else {
1956 60         104 $i++;
1957             }
1958             }
1959 2500         2570 @singleoctet = ();
1960 10         14 for my $range (@singleoctet_ignorecase) {
1961 10 100       29 if (ref $range) {
1962 960 50       1440 if (scalar(@{$range}) == 1) {
  20 50       19  
1963 20         35 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1964             }
1965 0         0 elsif (scalar(@{$range}) == 2) {
1966 20         32 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1967             }
1968             else {
1969 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         24  
  20         27  
1970             }
1971             }
1972             }
1973             }
1974              
1975             # return character list
1976 20 50       91 if (scalar(@multipleoctet) >= 1) {
1977 44 0       227 if (scalar(@singleoctet) >= 1) {
1978              
1979             # any character other than multiple-octet and single octet character class
1980 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
1981             }
1982             else {
1983              
1984             # any character other than multiple-octet character class
1985 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
1986             }
1987             }
1988             else {
1989 0 50       0 if (scalar(@singleoctet) >= 1) {
1990              
1991             # any character other than single octet character class
1992 44         100 return '(?:[^' . join('', @singleoctet) . '])';
1993             }
1994             else {
1995              
1996             # any character
1997 44         608 return "(?:$your_char)";
1998             }
1999             }
2000             }
2001              
2002             #
2003             # open file in read mode
2004             #
2005             sub _open_r {
2006 0     408   0 my(undef,$file) = @_;
2007 204     204   2180 use Fcntl qw(O_RDONLY);
  204         474  
  204         33129  
2008 408         3345 return CORE::sysopen($_[0], $file, &O_RDONLY);
2009             }
2010              
2011             #
2012             # open file in append mode
2013             #
2014             sub _open_a {
2015 408     204   24255 my(undef,$file) = @_;
2016 204     204   1584 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         758  
  204         625721  
2017 204         1254 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2018             }
2019              
2020             #
2021             # safe system
2022             #
2023             sub _systemx {
2024              
2025             # P.707 29.2.33. exec
2026             # in Chapter 29: Functions
2027             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2028             #
2029             # Be aware that in older releases of Perl, exec (and system) did not flush
2030             # your output buffer, so you needed to enable command buffering by setting $|
2031             # on one or more filehandles to avoid lost output in the case of exec, or
2032             # misordererd output in the case of system. This situation was largely remedied
2033             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2034              
2035             # P.855 exec
2036             # in Chapter 27: Functions
2037             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2038             #
2039             # In very old release of Perl (before v5.6), exec (and system) did not flush
2040             # your output buffer, so you needed to enable command buffering by setting $|
2041             # on one or more filehandles to avoid lost output with exec or misordered
2042             # output with system.
2043              
2044 204     204   53589 $| = 1;
2045              
2046             # P.565 23.1.2. Cleaning Up Your Environment
2047             # in Chapter 23: Security
2048             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2049              
2050             # P.656 Cleaning Up Your Environment
2051             # in Chapter 20: Security
2052             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2053              
2054             # local $ENV{'PATH'} = '.';
2055 204         732 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2056              
2057             # P.707 29.2.33. exec
2058             # in Chapter 29: Functions
2059             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2060             #
2061             # As we mentioned earlier, exec treats a discrete list of arguments as an
2062             # indication that it should bypass shell processing. However, there is one
2063             # place where you might still get tripped up. The exec call (and system, too)
2064             # will not distinguish between a single scalar argument and an array containing
2065             # only one element.
2066             #
2067             # @args = ("echo surprise"); # just one element in list
2068             # exec @args # still subject to shell escapes
2069             # or die "exec: $!"; # because @args == 1
2070             #
2071             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2072             # first argument as the pathname, which forces the rest of the arguments to be
2073             # interpreted as a list, even if there is only one of them:
2074             #
2075             # exec { $args[0] } @args # safe even with one-argument list
2076             # or die "can't exec @args: $!";
2077              
2078             # P.855 exec
2079             # in Chapter 27: Functions
2080             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2081             #
2082             # As we mentioned earlier, exec treats a discrete list of arguments as a
2083             # directive to bypass shell processing. However, there is one place where
2084             # you might still get tripped up. The exec call (and system, too) cannot
2085             # distinguish between a single scalar argument and an array containing
2086             # only one element.
2087             #
2088             # @args = ("echo surprise"); # just one element in list
2089             # exec @args # still subject to shell escapes
2090             # || die "exec: $!"; # because @args == 1
2091             #
2092             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2093             # argument as the pathname, which forces the rest of the arguments to be
2094             # interpreted as a list, even if there is only one of them:
2095             #
2096             # exec { $args[0] } @args # safe even with one-argument list
2097             # || die "can't exec @args: $!";
2098              
2099 204         1754 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         433  
2100             }
2101              
2102             #
2103             # US-ASCII order to character (with parameter)
2104             #
2105             sub Eusascii::chr(;$) {
2106              
2107 204 0   0 0 20372109 my $c = @_ ? $_[0] : $_;
2108              
2109 0 0       0 if ($c == 0x00) {
2110 0         0 return "\x00";
2111             }
2112             else {
2113 0         0 my @chr = ();
2114 0         0 while ($c > 0) {
2115 0         0 unshift @chr, ($c % 0x100);
2116 0         0 $c = int($c / 0x100);
2117             }
2118 0         0 return pack 'C*', @chr;
2119             }
2120             }
2121              
2122             #
2123             # US-ASCII order to character (without parameter)
2124             #
2125             sub Eusascii::chr_() {
2126              
2127 0     0 0 0 my $c = $_;
2128              
2129 0 0       0 if ($c == 0x00) {
2130 0         0 return "\x00";
2131             }
2132             else {
2133 0         0 my @chr = ();
2134 0         0 while ($c > 0) {
2135 0         0 unshift @chr, ($c % 0x100);
2136 0         0 $c = int($c / 0x100);
2137             }
2138 0         0 return pack 'C*', @chr;
2139             }
2140             }
2141              
2142             #
2143             # US-ASCII path globbing (with parameter)
2144             #
2145             sub Eusascii::glob($) {
2146              
2147 0 0   0 0 0 if (wantarray) {
2148 0         0 my @glob = _DOS_like_glob(@_);
2149 0         0 for my $glob (@glob) {
2150 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2151             }
2152 0         0 return @glob;
2153             }
2154             else {
2155 0         0 my $glob = _DOS_like_glob(@_);
2156 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2157 0         0 return $glob;
2158             }
2159             }
2160              
2161             #
2162             # US-ASCII path globbing (without parameter)
2163             #
2164             sub Eusascii::glob_() {
2165              
2166 0 0   0 0 0 if (wantarray) {
2167 0         0 my @glob = _DOS_like_glob();
2168 0         0 for my $glob (@glob) {
2169 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2170             }
2171 0         0 return @glob;
2172             }
2173             else {
2174 0         0 my $glob = _DOS_like_glob();
2175 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2176 0         0 return $glob;
2177             }
2178             }
2179              
2180             #
2181             # US-ASCII path globbing via File::DosGlob 1.10
2182             #
2183             # Often I confuse "_dosglob" and "_doglob".
2184             # So, I renamed "_dosglob" to "_DOS_like_glob".
2185             #
2186             my %iter;
2187             my %entries;
2188             sub _DOS_like_glob {
2189              
2190             # context (keyed by second cxix argument provided by core)
2191 0     0   0 my($expr,$cxix) = @_;
2192              
2193             # glob without args defaults to $_
2194 0 0       0 $expr = $_ if not defined $expr;
2195              
2196             # represents the current user's home directory
2197             #
2198             # 7.3. Expanding Tildes in Filenames
2199             # in Chapter 7. File Access
2200             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2201             #
2202             # and File::HomeDir, File::HomeDir::Windows module
2203              
2204             # DOS-like system
2205 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2206 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2207             { my_home_MSWin32() }oxmse;
2208             }
2209              
2210             # UNIX-like system
2211 0 0 0     0 else {
  0         0  
2212             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2213             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2214             }
2215 0 0       0  
2216 0 0       0 # assume global context if not provided one
2217             $cxix = '_G_' if not defined $cxix;
2218             $iter{$cxix} = 0 if not exists $iter{$cxix};
2219 0 0       0  
2220 0         0 # if we're just beginning, do it all first
2221             if ($iter{$cxix} == 0) {
2222             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2223             }
2224 0 0       0  
2225 0         0 # chuck it all out, quick or slow
2226 0         0 if (wantarray) {
  0         0  
2227             delete $iter{$cxix};
2228             return @{delete $entries{$cxix}};
2229 0 0       0 }
  0         0  
2230 0         0 else {
  0         0  
2231             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2232             return shift @{$entries{$cxix}};
2233             }
2234 0         0 else {
2235 0         0 # return undef for EOL
2236 0         0 delete $iter{$cxix};
2237             delete $entries{$cxix};
2238             return undef;
2239             }
2240             }
2241             }
2242              
2243             #
2244             # US-ASCII path globbing subroutine
2245             #
2246 0     0   0 sub _do_glob {
2247 0         0  
2248 0         0 my($cond,@expr) = @_;
2249             my @glob = ();
2250             my $fix_drive_relative_paths = 0;
2251 0         0  
2252 0 0       0 OUTER:
2253 0 0       0 for my $expr (@expr) {
2254             next OUTER if not defined $expr;
2255 0         0 next OUTER if $expr eq '';
2256 0         0  
2257 0         0 my @matched = ();
2258 0         0 my @globdir = ();
2259 0         0 my $head = '.';
2260             my $pathsep = '/';
2261             my $tail;
2262 0 0       0  
2263 0         0 # if argument is within quotes strip em and do no globbing
2264 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2265 0 0       0 $expr = $1;
2266 0         0 if ($cond eq 'd') {
2267             if (-d $expr) {
2268             push @glob, $expr;
2269             }
2270 0 0       0 }
2271 0         0 else {
2272             if (-e $expr) {
2273             push @glob, $expr;
2274 0         0 }
2275             }
2276             next OUTER;
2277             }
2278              
2279 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2280 0 0       0 # to h:./*.pm to expand correctly
2281 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2282             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2283             $fix_drive_relative_paths = 1;
2284             }
2285 0 0       0 }
2286 0 0       0  
2287 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2288 0         0 if ($tail eq '') {
2289             push @glob, $expr;
2290 0 0       0 next OUTER;
2291 0 0       0 }
2292 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2293 0         0 if (@globdir = _do_glob('d', $head)) {
2294             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2295             next OUTER;
2296 0 0 0     0 }
2297 0         0 }
2298             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2299 0         0 $head .= $pathsep;
2300             }
2301             $expr = $tail;
2302             }
2303 0 0       0  
2304 0 0       0 # If file component has no wildcards, we can avoid opendir
2305 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2306             if ($head eq '.') {
2307 0 0 0     0 $head = '';
2308 0         0 }
2309             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2310 0         0 $head .= $pathsep;
2311 0 0       0 }
2312 0 0       0 $head .= $expr;
2313 0         0 if ($cond eq 'd') {
2314             if (-d $head) {
2315             push @glob, $head;
2316             }
2317 0 0       0 }
2318 0         0 else {
2319             if (-e $head) {
2320             push @glob, $head;
2321 0         0 }
2322             }
2323 0 0       0 next OUTER;
2324 0         0 }
2325 0         0 opendir(*DIR, $head) or next OUTER;
2326             my @leaf = readdir DIR;
2327 0 0       0 closedir DIR;
2328 0         0  
2329             if ($head eq '.') {
2330 0 0 0     0 $head = '';
2331 0         0 }
2332             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2333             $head .= $pathsep;
2334 0         0 }
2335 0         0  
2336 0         0 my $pattern = '';
2337             while ($expr =~ / \G ($q_char) /oxgc) {
2338             my $char = $1;
2339              
2340             # 6.9. Matching Shell Globs as Regular Expressions
2341             # in Chapter 6. Pattern Matching
2342             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2343 0 0       0 # (and so on)
    0          
    0          
2344 0         0  
2345             if ($char eq '*') {
2346             $pattern .= "(?:$your_char)*",
2347 0         0 }
2348             elsif ($char eq '?') {
2349             $pattern .= "(?:$your_char)?", # DOS style
2350             # $pattern .= "(?:$your_char)", # UNIX style
2351 0         0 }
2352             elsif ((my $fc = Eusascii::fc($char)) ne $char) {
2353             $pattern .= $fc;
2354 0         0 }
2355             else {
2356             $pattern .= quotemeta $char;
2357 0     0   0 }
  0         0  
2358             }
2359             my $matchsub = sub { Eusascii::fc($_[0]) =~ /\A $pattern \z/xms };
2360              
2361             # if ($@) {
2362             # print STDERR "$0: $@\n";
2363             # next OUTER;
2364             # }
2365 0         0  
2366 0 0 0     0 INNER:
2367 0         0 for my $leaf (@leaf) {
2368             if ($leaf eq '.' or $leaf eq '..') {
2369 0 0 0     0 next INNER;
2370 0         0 }
2371             if ($cond eq 'd' and not -d "$head$leaf") {
2372             next INNER;
2373 0 0       0 }
2374 0         0  
2375 0         0 if (&$matchsub($leaf)) {
2376             push @matched, "$head$leaf";
2377             next INNER;
2378             }
2379              
2380             # [DOS compatibility special case]
2381 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2382              
2383             if (Eusascii::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2384             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2385 0 0       0 Eusascii::index($pattern,'\\.') != -1 # pattern has a dot.
2386 0         0 ) {
2387 0         0 if (&$matchsub("$leaf.")) {
2388             push @matched, "$head$leaf";
2389             next INNER;
2390             }
2391 0 0       0 }
2392 0         0 }
2393             if (@matched) {
2394             push @glob, @matched;
2395 0 0       0 }
2396 0         0 }
2397 0         0 if ($fix_drive_relative_paths) {
2398             for my $glob (@glob) {
2399             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2400 0         0 }
2401             }
2402             return @glob;
2403             }
2404              
2405             #
2406             # US-ASCII parse line
2407             #
2408 0     0   0 sub _parse_line {
2409              
2410 0         0 my($line) = @_;
2411 0         0  
2412 0         0 $line .= ' ';
2413             my @piece = ();
2414             while ($line =~ /
2415             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2416             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2417 0 0       0 /oxmsg
2418             ) {
2419 0         0 push @piece, defined($1) ? $1 : $2;
2420             }
2421             return @piece;
2422             }
2423              
2424             #
2425             # US-ASCII parse path
2426             #
2427 0     0   0 sub _parse_path {
2428              
2429 0         0 my($path,$pathsep) = @_;
2430 0         0  
2431 0         0 $path .= '/';
2432             my @subpath = ();
2433             while ($path =~ /
2434             ((?: [^\/\\] )+?) [\/\\]
2435 0         0 /oxmsg
2436             ) {
2437             push @subpath, $1;
2438 0         0 }
2439 0         0  
2440 0         0 my $tail = pop @subpath;
2441             my $head = join $pathsep, @subpath;
2442             return $head, $tail;
2443             }
2444              
2445             #
2446             # via File::HomeDir::Windows 1.00
2447             #
2448             sub my_home_MSWin32 {
2449              
2450             # A lot of unix people and unix-derived tools rely on
2451 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2452 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2453             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2454             return $ENV{'HOME'};
2455             }
2456              
2457 0         0 # Do we have a user profile?
2458             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2459             return $ENV{'USERPROFILE'};
2460             }
2461              
2462 0         0 # Some Windows use something like $ENV{'HOME'}
2463             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2464             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2465 0         0 }
2466              
2467             return undef;
2468             }
2469              
2470             #
2471             # via File::HomeDir::Unix 1.00
2472 0     0 0 0 #
2473             sub my_home {
2474 0 0 0     0 my $home;
    0 0        
2475 0         0  
2476             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2477             $home = $ENV{'HOME'};
2478             }
2479              
2480             # This is from the original code, but I'm guessing
2481 0         0 # it means "login directory" and exists on some Unixes.
2482             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2483             $home = $ENV{'LOGDIR'};
2484             }
2485              
2486             ### More-desperate methods
2487              
2488 0         0 # Light desperation on any (Unixish) platform
2489             else {
2490             $home = CORE::eval q{ (getpwuid($<))[7] };
2491             }
2492              
2493 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2494 0         0 # For example, "nobody"-like users might use /nonexistant
2495             if (defined $home and ! -d($home)) {
2496 0         0 $home = undef;
2497             }
2498             return $home;
2499             }
2500              
2501             #
2502             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2503 0     0 0 0 #
2504             sub Eusascii::PREMATCH {
2505             return $`;
2506             }
2507              
2508             #
2509             # ${^MATCH}, $MATCH, $& the string that matched
2510 0     0 0 0 #
2511             sub Eusascii::MATCH {
2512             return $&;
2513             }
2514              
2515             #
2516             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2517 0     0 0 0 #
2518             sub Eusascii::POSTMATCH {
2519             return $';
2520             }
2521              
2522             #
2523             # US-ASCII character to order (with parameter)
2524             #
2525 0 0   0 1 0 sub USASCII::ord(;$) {
2526              
2527 0 0       0 local $_ = shift if @_;
2528 0         0  
2529 0         0 if (/\A ($q_char) /oxms) {
2530 0         0 my @ord = unpack 'C*', $1;
2531 0         0 my $ord = 0;
2532             while (my $o = shift @ord) {
2533 0         0 $ord = $ord * 0x100 + $o;
2534             }
2535             return $ord;
2536 0         0 }
2537             else {
2538             return CORE::ord $_;
2539             }
2540             }
2541              
2542             #
2543             # US-ASCII character to order (without parameter)
2544             #
2545 0 0   0 0 0 sub USASCII::ord_() {
2546 0         0  
2547 0         0 if (/\A ($q_char) /oxms) {
2548 0         0 my @ord = unpack 'C*', $1;
2549 0         0 my $ord = 0;
2550             while (my $o = shift @ord) {
2551 0         0 $ord = $ord * 0x100 + $o;
2552             }
2553             return $ord;
2554 0         0 }
2555             else {
2556             return CORE::ord $_;
2557             }
2558             }
2559              
2560             #
2561             # US-ASCII reverse
2562             #
2563 0 0   0 0 0 sub USASCII::reverse(@) {
2564 0         0  
2565             if (wantarray) {
2566             return CORE::reverse @_;
2567             }
2568             else {
2569              
2570             # One of us once cornered Larry in an elevator and asked him what
2571             # problem he was solving with this, but he looked as far off into
2572             # the distance as he could in an elevator and said, "It seemed like
2573 0         0 # a good idea at the time."
2574              
2575             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2576             }
2577             }
2578              
2579             #
2580             # US-ASCII getc (with parameter, without parameter)
2581             #
2582 0     0 0 0 sub USASCII::getc(;*@) {
2583 0 0       0  
2584 0 0 0     0 my($package) = caller;
2585             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2586 0         0 croak 'Too many arguments for USASCII::getc' if @_ and not wantarray;
  0         0  
2587 0         0  
2588 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2589 0         0 my $getc = '';
2590 0 0       0 for my $length ($length[0] .. $length[-1]) {
2591 0 0       0 $getc .= CORE::getc($fh);
2592 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2593             if ($getc =~ /\A ${Eusascii::dot_s} \z/oxms) {
2594             return wantarray ? ($getc,@_) : $getc;
2595             }
2596 0 0       0 }
2597             }
2598             return wantarray ? ($getc,@_) : $getc;
2599             }
2600              
2601             #
2602             # US-ASCII length by character
2603             #
2604 0 0   0 1 0 sub USASCII::length(;$) {
2605              
2606 0         0 local $_ = shift if @_;
2607 0         0  
2608             local @_ = /\G ($q_char) /oxmsg;
2609             return scalar @_;
2610             }
2611              
2612             #
2613             # US-ASCII substr by character
2614             #
2615             BEGIN {
2616              
2617             # P.232 The lvalue Attribute
2618             # in Chapter 6: Subroutines
2619             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2620              
2621             # P.336 The lvalue Attribute
2622             # in Chapter 7: Subroutines
2623             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2624              
2625             # P.144 8.4 Lvalue subroutines
2626             # in Chapter 8: perlsub: Perl subroutines
2627 204 50 0 204 1 128505 # 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  
2628              
2629             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2630             # vv----------------------*******
2631             sub USASCII::substr($$;$$) %s {
2632              
2633             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2634              
2635             # If the substring is beyond either end of the string, substr() returns the undefined
2636             # value and produces a warning. When used as an lvalue, specifying a substring that
2637             # is entirely outside the string raises an exception.
2638             # http://perldoc.perl.org/functions/substr.html
2639              
2640             # A return with no argument returns the scalar value undef in scalar context,
2641             # an empty list () in list context, and (naturally) nothing at all in void
2642             # context.
2643              
2644             my $offset = $_[1];
2645             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2646             return;
2647             }
2648              
2649             # substr($string,$offset,$length,$replacement)
2650             if (@_ == 4) {
2651             my(undef,undef,$length,$replacement) = @_;
2652             my $substr = join '', splice(@char, $offset, $length, $replacement);
2653             $_[0] = join '', @char;
2654              
2655             # return $substr; this doesn't work, don't say "return"
2656             $substr;
2657             }
2658              
2659             # substr($string,$offset,$length)
2660             elsif (@_ == 3) {
2661             my(undef,undef,$length) = @_;
2662             my $octet_offset = 0;
2663             my $octet_length = 0;
2664             if ($offset == 0) {
2665             $octet_offset = 0;
2666             }
2667             elsif ($offset > 0) {
2668             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2669             }
2670             else {
2671             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2672             }
2673             if ($length == 0) {
2674             $octet_length = 0;
2675             }
2676             elsif ($length > 0) {
2677             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2678             }
2679             else {
2680             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2681             }
2682             CORE::substr($_[0], $octet_offset, $octet_length);
2683             }
2684              
2685             # substr($string,$offset)
2686             else {
2687             my $octet_offset = 0;
2688             if ($offset == 0) {
2689             $octet_offset = 0;
2690             }
2691             elsif ($offset > 0) {
2692             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2693             }
2694             else {
2695             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2696             }
2697             CORE::substr($_[0], $octet_offset);
2698             }
2699             }
2700             END
2701             }
2702              
2703             #
2704             # US-ASCII index by character
2705             #
2706 0     0 1 0 sub USASCII::index($$;$) {
2707 0 0       0  
2708 0         0 my $index;
2709             if (@_ == 3) {
2710             $index = Eusascii::index($_[0], $_[1], CORE::length(USASCII::substr($_[0], 0, $_[2])));
2711 0         0 }
2712             else {
2713             $index = Eusascii::index($_[0], $_[1]);
2714 0 0       0 }
2715 0         0  
2716             if ($index == -1) {
2717             return -1;
2718 0         0 }
2719             else {
2720             return USASCII::length(CORE::substr $_[0], 0, $index);
2721             }
2722             }
2723              
2724             #
2725             # US-ASCII rindex by character
2726             #
2727 0     0 1 0 sub USASCII::rindex($$;$) {
2728 0 0       0  
2729 0         0 my $rindex;
2730             if (@_ == 3) {
2731             $rindex = Eusascii::rindex($_[0], $_[1], CORE::length(USASCII::substr($_[0], 0, $_[2])));
2732 0         0 }
2733             else {
2734             $rindex = Eusascii::rindex($_[0], $_[1]);
2735 0 0       0 }
2736 0         0  
2737             if ($rindex == -1) {
2738             return -1;
2739 0         0 }
2740             else {
2741             return USASCII::length(CORE::substr $_[0], 0, $rindex);
2742             }
2743             }
2744              
2745 204     204   3559 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         833  
  204         32131  
2746             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2747             use vars qw($slash); $slash = 'm//';
2748              
2749             # ord() to ord() or USASCII::ord()
2750             my $function_ord = 'ord';
2751              
2752             # ord to ord or USASCII::ord_
2753             my $function_ord_ = 'ord';
2754              
2755             # reverse to reverse or USASCII::reverse
2756             my $function_reverse = 'reverse';
2757              
2758             # getc to getc or USASCII::getc
2759             my $function_getc = 'getc';
2760              
2761             # P.1023 Appendix W.9 Multibyte Anchoring
2762             # of ISBN 1-56592-224-7 CJKV Information Processing
2763              
2764 204     204   1601 my $anchor = '';
  204     0   361  
  204         9967252  
2765              
2766             use vars qw($nest);
2767              
2768             # regexp of nested parens in qqXX
2769              
2770             # P.340 Matching Nested Constructs with Embedded Code
2771             # in Chapter 7: Perl
2772             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2773              
2774             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2775             [^\\()] |
2776             \( (?{$nest++}) |
2777             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2778             \\ [^c] |
2779             \\c[\x40-\x5F] |
2780             [\x00-\xFF]
2781             }xms;
2782              
2783             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2784             [^\\{}] |
2785             \{ (?{$nest++}) |
2786             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2787             \\ [^c] |
2788             \\c[\x40-\x5F] |
2789             [\x00-\xFF]
2790             }xms;
2791              
2792             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2793             [^\\\[\]] |
2794             \[ (?{$nest++}) |
2795             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2796             \\ [^c] |
2797             \\c[\x40-\x5F] |
2798             [\x00-\xFF]
2799             }xms;
2800              
2801             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2802             [^\\<>] |
2803             \< (?{$nest++}) |
2804             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2805             \\ [^c] |
2806             \\c[\x40-\x5F] |
2807             [\x00-\xFF]
2808             }xms;
2809              
2810             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2811             (?: ::)? (?:
2812             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2813             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2814             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2815             ))
2816             }xms;
2817              
2818             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2819             (?: ::)? (?:
2820             (?>[0-9]+) |
2821             [^a-zA-Z_0-9\[\]] |
2822             ^[A-Z] |
2823             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2824             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2825             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2826             ))
2827             }xms;
2828              
2829             my $qq_substr = qr{(?> Char::substr | USASCII::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2830             }xms;
2831              
2832             # regexp of nested parens in qXX
2833             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2834             [^()] |
2835             \( (?{$nest++}) |
2836             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2837             [\x00-\xFF]
2838             }xms;
2839              
2840             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2841             [^\{\}] |
2842             \{ (?{$nest++}) |
2843             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2844             [\x00-\xFF]
2845             }xms;
2846              
2847             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2848             [^\[\]] |
2849             \[ (?{$nest++}) |
2850             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2851             [\x00-\xFF]
2852             }xms;
2853              
2854             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2855             [^<>] |
2856             \< (?{$nest++}) |
2857             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2858             [\x00-\xFF]
2859             }xms;
2860              
2861             my $matched = '';
2862             my $s_matched = '';
2863              
2864             my $tr_variable = ''; # variable of tr///
2865             my $sub_variable = ''; # variable of s///
2866             my $bind_operator = ''; # =~ or !~
2867              
2868             my @heredoc = (); # here document
2869             my @heredoc_delimiter = ();
2870             my $here_script = ''; # here script
2871              
2872             #
2873             # escape US-ASCII script
2874 0 50   204 0 0 #
2875             sub USASCII::escape(;$) {
2876             local($_) = $_[0] if @_;
2877              
2878             # P.359 The Study Function
2879             # in Chapter 7: Perl
2880 204         678 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2881              
2882             study $_; # Yes, I studied study yesterday.
2883              
2884             # while all script
2885              
2886             # 6.14. Matching from Where the Last Pattern Left Off
2887             # in Chapter 6. Pattern Matching
2888             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2889             # (and so on)
2890              
2891             # one member of Tag-team
2892             #
2893             # P.128 Start of match (or end of previous match): \G
2894             # P.130 Advanced Use of \G with Perl
2895             # in Chapter 3: Overview of Regular Expression Features and Flavors
2896             # P.255 Use leading anchors
2897             # P.256 Expose ^ and \G at the front expressions
2898             # in Chapter 6: Crafting an Efficient Expression
2899             # P.315 "Tag-team" matching with /gc
2900             # in Chapter 7: Perl
2901 204         438 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2902 204         345  
2903 204         852 my $e_script = '';
2904             while (not /\G \z/oxgc) { # member
2905             $e_script .= USASCII::escape_token();
2906 73227         120803 }
2907              
2908             return $e_script;
2909             }
2910              
2911             #
2912             # escape US-ASCII token of script
2913             #
2914             sub USASCII::escape_token {
2915              
2916 204     73227 0 2796 # \n output here document
2917              
2918             my $ignore_modules = join('|', qw(
2919             utf8
2920             bytes
2921             charnames
2922             I18N::Japanese
2923             I18N::Collate
2924             I18N::JExt
2925             File::DosGlob
2926             Wild
2927             Wildcard
2928             Japanese
2929             ));
2930              
2931             # another member of Tag-team
2932             #
2933             # P.315 "Tag-team" matching with /gc
2934             # in Chapter 7: Perl
2935 73227 100 100     89111 # 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          
2936 73227         2996753  
2937 12245 100       15127 if (/\G ( \n ) /oxgc) { # another member (and so on)
2938 12245         21615 my $heredoc = '';
2939             if (scalar(@heredoc_delimiter) >= 1) {
2940 174         240 $slash = 'm//';
2941 174         416  
2942             $heredoc = join '', @heredoc;
2943             @heredoc = ();
2944 174         321  
2945 174         319 # skip here document
2946             for my $heredoc_delimiter (@heredoc_delimiter) {
2947 174         3007 /\G .*? \n $heredoc_delimiter \n/xmsgc;
2948             }
2949 174         309 @heredoc_delimiter = ();
2950              
2951 174         344 $here_script = '';
2952             }
2953             return "\n" . $heredoc;
2954             }
2955 12245         37640  
2956             # ignore space, comment
2957             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
2958              
2959             # if (, elsif (, unless (, while (, until (, given (, and when (
2960              
2961             # given, when
2962              
2963             # P.225 The given Statement
2964             # in Chapter 15: Smart Matching and given-when
2965             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
2966              
2967             # P.133 The given Statement
2968             # in Chapter 4: Statements and Declarations
2969             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2970 17216         60926  
2971 1379         2148 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
2972             $slash = 'm//';
2973             return $1;
2974             }
2975              
2976             # scalar variable ($scalar = ...) =~ tr///;
2977             # scalar variable ($scalar = ...) =~ s///;
2978              
2979             # state
2980              
2981             # P.68 Persistent, Private Variables
2982             # in Chapter 4: Subroutines
2983             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
2984              
2985             # P.160 Persistent Lexically Scoped Variables: state
2986             # in Chapter 4: Statements and Declarations
2987             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2988              
2989             # (and so on)
2990 1379         4294  
2991             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
2992 86 50       273 my $e_string = e_string($1);
    50          
2993 86         2126  
2994 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
2995 0         0 $tr_variable = $e_string . e_string($1);
2996 0         0 $bind_operator = $2;
2997             $slash = 'm//';
2998             return '';
2999 0         0 }
3000 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3001 0         0 $sub_variable = $e_string . e_string($1);
3002 0         0 $bind_operator = $2;
3003             $slash = 'm//';
3004             return '';
3005 0         0 }
3006 86         148 else {
3007             $slash = 'div';
3008             return $e_string;
3009             }
3010             }
3011              
3012 86         271 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
3013 4         8 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3014             $slash = 'div';
3015             return q{Eusascii::PREMATCH()};
3016             }
3017              
3018 4         12 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
3019 28         258 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3020             $slash = 'div';
3021             return q{Eusascii::MATCH()};
3022             }
3023              
3024 28         96 # $', ${'} --> $', ${'}
3025 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3026             $slash = 'div';
3027             return $1;
3028             }
3029              
3030 1         3 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
3031 3         7 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3032             $slash = 'div';
3033             return q{Eusascii::POSTMATCH()};
3034             }
3035              
3036             # scalar variable $scalar =~ tr///;
3037             # scalar variable $scalar =~ s///;
3038             # substr() =~ tr///;
3039 3         9 # substr() =~ s///;
3040             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3041 1668 100       3707 my $scalar = e_string($1);
    100          
3042 1668         6736  
3043 1         2 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3044 1         2 $tr_variable = $scalar;
3045 1         2 $bind_operator = $1;
3046             $slash = 'm//';
3047             return '';
3048 1         2 }
3049 61         409 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3050 61         141 $sub_variable = $scalar;
3051 61         98 $bind_operator = $1;
3052             $slash = 'm//';
3053             return '';
3054 61         176 }
3055 1606         2330 else {
3056             $slash = 'div';
3057             return $scalar;
3058             }
3059             }
3060              
3061 1606         4571 # end of statement
3062             elsif (/\G ( [,;] ) /oxgc) {
3063             $slash = 'm//';
3064 4831         11043  
3065             # clear tr/// variable
3066             $tr_variable = '';
3067 4831         6123  
3068             # clear s/// variable
3069 4831         7051 $sub_variable = '';
3070              
3071 4831         5848 $bind_operator = '';
3072              
3073             return $1;
3074             }
3075              
3076 4831         17431 # bareword
3077             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3078             return $1;
3079             }
3080              
3081 0         0 # $0 --> $0
3082 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
3083             $slash = 'div';
3084             return $1;
3085 2         8 }
3086 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3087             $slash = 'div';
3088             return $1;
3089             }
3090              
3091 0         0 # $$ --> $$
3092 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3093             $slash = 'div';
3094             return $1;
3095             }
3096              
3097             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3098 1         3 # $1, $2, $3 --> $1, $2, $3 otherwise
3099 4         6 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3100             $slash = 'div';
3101             return e_capture($1);
3102 4         8 }
3103 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3104             $slash = 'div';
3105             return e_capture($1);
3106             }
3107              
3108 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3109 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3110             $slash = 'div';
3111             return e_capture($1.'->'.$2);
3112             }
3113              
3114 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3115 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3116             $slash = 'div';
3117             return e_capture($1.'->'.$2);
3118             }
3119              
3120 0         0 # $$foo
3121 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3122             $slash = 'div';
3123             return e_capture($1);
3124             }
3125              
3126 0         0 # ${ foo }
3127 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3128             $slash = 'div';
3129             return '${' . $1 . '}';
3130             }
3131              
3132 0         0 # ${ ... }
3133 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3134             $slash = 'div';
3135             return e_capture($1);
3136             }
3137              
3138             # variable or function
3139 0         0 # $ @ % & * $ #
3140 32         61 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) {
3141             $slash = 'div';
3142             return $1;
3143             }
3144             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3145 32         99 # $ @ # \ ' " / ? ( ) [ ] < >
3146 62         118 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3147             $slash = 'div';
3148             return $1;
3149             }
3150              
3151 62         214 # while ()
3152             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3153             return $1;
3154             }
3155              
3156             # while () --- glob
3157              
3158             # avoid "Error: Runtime exception" of perl version 5.005_03
3159 0         0  
3160             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3161             return 'while ($_ = Eusascii::glob("' . $1 . '"))';
3162             }
3163              
3164 0         0 # while (glob)
3165             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3166             return 'while ($_ = Eusascii::glob_)';
3167             }
3168              
3169 0         0 # while (glob(WILDCARD))
3170             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3171             return 'while ($_ = Eusascii::glob';
3172             }
3173 0         0  
  248         558  
3174             # doit if, doit unless, doit while, doit until, doit for, doit when
3175             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3176 248         911  
  19         31  
3177 19         69 # subroutines of package Eusascii
  0         0  
3178 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         19  
3179 13         35 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3180 0         0 elsif (/\G \b USASCII::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         181  
3181 114         324 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         3  
3182 2         7 elsif (/\G \b USASCII::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval USASCII::escape'; }
  0         0  
3183 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         5  
3184 2         6 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::chop'; }
  0         0  
3185 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3186 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3187 0         0 elsif (/\G \b USASCII::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'USASCII::index'; }
  2         5  
3188 2         6 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::index'; }
  0         0  
3189 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3190 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3191 0         0 elsif (/\G \b USASCII::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'USASCII::rindex'; }
  1         1  
3192 1         4 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::rindex'; }
  0         0  
3193 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::lc'; }
  1         2  
3194 1         4 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::lcfirst'; }
  0         0  
3195 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::uc'; }
  2         5  
3196             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::ucfirst'; }
3197             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::fc'; }
3198 2         5  
  0         0  
3199 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3200 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3201 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3202 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3203 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3204 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3205             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3206 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  
3207 0         0  
  0         0  
3208 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3209 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3210 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3211 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3212 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3213             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3214             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3215 0         0  
  0         0  
3216 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3217 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3218 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3219             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3220 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         4  
3221 2         7  
  2         3  
3222 2         6 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         70  
3223 36         106 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3224 2         6 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::chr'; }
  8         14  
3225 8         26 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3226 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3227 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Eusascii::glob'; }
  0         0  
3228 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::lc_'; }
  0         0  
3229 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::lcfirst_'; }
  0         0  
3230 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::uc_'; }
  0         0  
3231 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::ucfirst_'; }
  0         0  
3232             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::fc_'; }
3233 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3234 0         0  
  0         0  
3235 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3236 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3237 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::chr_'; }
  0         0  
3238 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3239 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3240 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Eusascii::glob_'; }
  8         20  
3241             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3242             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3243 8         29 # split
3244             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3245 87         176 $slash = 'm//';
3246 87         136  
3247 87         318 my $e = '';
3248             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3249             $e .= $1;
3250             }
3251 85 100       307  
  87 100       6023  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3252             # end of split
3253             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Eusascii::split' . $e; }
3254 2         9  
3255             # split scalar value
3256             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Eusascii::split' . $e . e_string($1); }
3257 1         174  
3258 0         0 # split literal space
3259 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Eusascii::split' . $e . qq {qq$1 $2}; }
3260 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Eusascii::split' . $e . qq{$1qq$2 $3}; }
3261 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Eusascii::split' . $e . qq{$1qq$2 $3}; }
3262 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Eusascii::split' . $e . qq{$1qq$2 $3}; }
3263 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Eusascii::split' . $e . qq{$1qq$2 $3}; }
3264 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Eusascii::split' . $e . qq{$1qq$2 $3}; }
3265 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Eusascii::split' . $e . qq {q$1 $2}; }
3266 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Eusascii::split' . $e . qq {$1q$2 $3}; }
3267 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Eusascii::split' . $e . qq {$1q$2 $3}; }
3268 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Eusascii::split' . $e . qq {$1q$2 $3}; }
3269 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Eusascii::split' . $e . qq {$1q$2 $3}; }
3270 10         42 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Eusascii::split' . $e . qq {$1q$2 $3}; }
3271             elsif (/\G ' [ ] ' /oxgc) { return 'Eusascii::split' . $e . qq {' '}; }
3272             elsif (/\G " [ ] " /oxgc) { return 'Eusascii::split' . $e . qq {" "}; }
3273              
3274 0 0       0 # split qq//
  0         0  
3275             elsif (/\G \b (qq) \b /oxgc) {
3276 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3277 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3278 0         0 while (not /\G \z/oxgc) {
3279 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3280 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3281 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3282 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3283 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3284             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3285 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3286             }
3287             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3288             }
3289             }
3290              
3291 0 50       0 # split qr//
  12         408  
3292             elsif (/\G \b (qr) \b /oxgc) {
3293 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3294 12 50       66 else {
  12 50       3383  
    50          
    50          
    50          
    50          
    50          
    50          
3295 0         0 while (not /\G \z/oxgc) {
3296 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3297 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3298 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3299 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3300 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3301 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3302             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3303 12         82 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3304             }
3305             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3306             }
3307             }
3308              
3309 0 0       0 # split q//
  0         0  
3310             elsif (/\G \b (q) \b /oxgc) {
3311 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3312 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3313 0         0 while (not /\G \z/oxgc) {
3314 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3315 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3316 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3317 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3318 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3319             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3320 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3321             }
3322             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3323             }
3324             }
3325              
3326 0 50       0 # split m//
  18         509  
3327             elsif (/\G \b (m) \b /oxgc) {
3328 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3329 18 50       73 else {
  18 50       3629  
    50          
    50          
    50          
    50          
    50          
    50          
3330 0         0 while (not /\G \z/oxgc) {
3331 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3332 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3333 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3334 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3335 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3336 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3337             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3338 18         124 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3339             }
3340             die __FILE__, ": Search pattern not terminated\n";
3341             }
3342             }
3343              
3344 0         0 # split ''
3345 0         0 elsif (/\G (\') /oxgc) {
3346 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3347 0         0 while (not /\G \z/oxgc) {
3348 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3349 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3350             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3351 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3352             }
3353             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3354             }
3355              
3356 0         0 # split ""
3357 0         0 elsif (/\G (\") /oxgc) {
3358 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3359 0         0 while (not /\G \z/oxgc) {
3360 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3361 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3362             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3363 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3364             }
3365             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3366             }
3367              
3368 0         0 # split //
3369 44         123 elsif (/\G (\/) /oxgc) {
3370 44 50       155 my $regexp = '';
  381 50       1504  
    100          
    50          
3371 0         0 while (not /\G \z/oxgc) {
3372 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3373 44         200 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3374             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3375 337         698 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3376             }
3377             die __FILE__, ": Search pattern not terminated\n";
3378             }
3379             }
3380              
3381             # tr/// or y///
3382              
3383             # about [cdsrbB]* (/B modifier)
3384             #
3385             # P.559 appendix C
3386             # of ISBN 4-89052-384-7 Programming perl
3387             # (Japanese title is: Perl puroguramingu)
3388 0         0  
3389             elsif (/\G \b ( tr | y ) \b /oxgc) {
3390             my $ope = $1;
3391 3 50       9  
3392 3         38 # $1 $2 $3 $4 $5 $6
3393 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3394             my @tr = ($tr_variable,$2);
3395             return e_tr(@tr,'',$4,$6);
3396 0         0 }
3397 3         5 else {
3398 3 50       7 my $e = '';
  3 50       230  
    50          
    50          
    50          
    50          
3399             while (not /\G \z/oxgc) {
3400 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3401 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3402 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3403 0         0 while (not /\G \z/oxgc) {
3404 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3405 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3406 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3407 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3408             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3409 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3410             }
3411             die __FILE__, ": Transliteration replacement not terminated\n";
3412 0         0 }
3413 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3414 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3415 0         0 while (not /\G \z/oxgc) {
3416 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3417 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3418 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3419 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3420             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3421 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3422             }
3423             die __FILE__, ": Transliteration replacement not terminated\n";
3424 0         0 }
3425 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3426 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3427 0         0 while (not /\G \z/oxgc) {
3428 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3429 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3430 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3431 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3432             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3433 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3434             }
3435             die __FILE__, ": Transliteration replacement not terminated\n";
3436 0         0 }
3437 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3438 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3439 0         0 while (not /\G \z/oxgc) {
3440 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3441 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3442 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3443 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3444             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3445 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3446             }
3447             die __FILE__, ": Transliteration replacement not terminated\n";
3448             }
3449 0         0 # $1 $2 $3 $4 $5 $6
3450 3         11 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3451             my @tr = ($tr_variable,$2);
3452             return e_tr(@tr,'',$4,$6);
3453 3         7 }
3454             }
3455             die __FILE__, ": Transliteration pattern not terminated\n";
3456             }
3457             }
3458              
3459 0         0 # qq//
3460             elsif (/\G \b (qq) \b /oxgc) {
3461             my $ope = $1;
3462 2136 50       5233  
3463 2136         3945 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3464 0         0 if (/\G (\#) /oxgc) { # qq# #
3465 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3466 0         0 while (not /\G \z/oxgc) {
3467 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3468 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3469             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3470 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3471             }
3472             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3473             }
3474 0         0  
3475 2136         2886 else {
3476 2136 50       5212 my $e = '';
  2136 50       8416  
    100          
    50          
    50          
    0          
3477             while (not /\G \z/oxgc) {
3478             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3479              
3480 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3481 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3482 0         0 my $qq_string = '';
3483 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3484 0         0 while (not /\G \z/oxgc) {
3485 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3486             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3487 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3488 0         0 elsif (/\G (\)) /oxgc) {
3489             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3490 0         0 else { $qq_string .= $1; }
3491             }
3492 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3493             }
3494             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3495             }
3496              
3497 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3498 2106         3001 elsif (/\G (\{) /oxgc) { # qq { }
3499 2106         2944 my $qq_string = '';
3500 2106 100       4875 local $nest = 1;
  83317 50       287128  
    100          
    100          
    50          
3501 610         1158 while (not /\G \z/oxgc) {
3502 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1173         1635  
3503             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3504 1173 100       2011 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3279         5060  
3505 2106         6005 elsif (/\G (\}) /oxgc) {
3506             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3507 1173         3816 else { $qq_string .= $1; }
3508             }
3509 78255         174170 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3510             }
3511             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3512             }
3513              
3514 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3515 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3516 0         0 my $qq_string = '';
3517 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3518 0         0 while (not /\G \z/oxgc) {
3519 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3520             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3521 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3522 0         0 elsif (/\G (\]) /oxgc) {
3523             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3524 0         0 else { $qq_string .= $1; }
3525             }
3526 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3527             }
3528             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3529             }
3530              
3531 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3532 30         50 elsif (/\G (\<) /oxgc) { # qq < >
3533 30         49 my $qq_string = '';
3534 30 100       97 local $nest = 1;
  1166 50       3764  
    50          
    100          
    50          
3535 22         155 while (not /\G \z/oxgc) {
3536 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3537             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3538 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         64  
3539 30         102 elsif (/\G (\>) /oxgc) {
3540             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3541 0         0 else { $qq_string .= $1; }
3542             }
3543 1114         2114 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3544             }
3545             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3546             }
3547              
3548 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3549 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3550 0         0 my $delimiter = $1;
3551 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3552 0         0 while (not /\G \z/oxgc) {
3553 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3554 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3555             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3556 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3557             }
3558             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3559 0         0 }
3560             }
3561             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3562             }
3563             }
3564              
3565 0         0 # qr//
3566 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3567 0         0 my $ope = $1;
3568             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3569             return e_qr($ope,$1,$3,$2,$4);
3570 0         0 }
3571 0         0 else {
3572 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3573 0         0 while (not /\G \z/oxgc) {
3574 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3575 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3576 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3577 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3578 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3579 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3580             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3581 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3582             }
3583             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3584             }
3585             }
3586              
3587 0         0 # qw//
3588 14 50       40 elsif (/\G \b (qw) \b /oxgc) {
3589 14         44 my $ope = $1;
3590             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3591             return e_qw($ope,$1,$3,$2);
3592 0         0 }
3593 14         24 else {
3594 14 50       65 my $e = '';
  14 50       111  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3595             while (not /\G \z/oxgc) {
3596 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3597 14         51  
3598             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3599 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3600 0         0  
3601             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3602 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3603 0         0  
3604             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3605 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3606 0         0  
3607             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3608 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3609 0         0  
3610             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3611 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3612             }
3613             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3614             }
3615             }
3616              
3617 0         0 # qx//
3618 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3619 0         0 my $ope = $1;
3620             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3621             return e_qq($ope,$1,$3,$2);
3622 0         0 }
3623 0         0 else {
3624 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3625 0         0 while (not /\G \z/oxgc) {
3626 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3627 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3628 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3629 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3630 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3631             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3632 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3633             }
3634             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3635             }
3636             }
3637              
3638 0         0 # q//
3639             elsif (/\G \b (q) \b /oxgc) {
3640             my $ope = $1;
3641              
3642             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3643              
3644             # avoid "Error: Runtime exception" of perl version 5.005_03
3645 422 50       1507 # (and so on)
3646 422         1606  
3647 0         0 if (/\G (\#) /oxgc) { # q# #
3648 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3649 0         0 while (not /\G \z/oxgc) {
3650 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3651 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3652             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3653 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3654             }
3655             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3656             }
3657 0         0  
3658 422         742 else {
3659 422 50       1280 my $e = '';
  422 50       2153  
    100          
    50          
    100          
    50          
3660             while (not /\G \z/oxgc) {
3661             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3662              
3663 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3664 0         0 elsif (/\G (\() /oxgc) { # q ( )
3665 0         0 my $q_string = '';
3666 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3667 0         0 while (not /\G \z/oxgc) {
3668 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3669 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3670             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3671 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3672 0         0 elsif (/\G (\)) /oxgc) {
3673             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3674 0         0 else { $q_string .= $1; }
3675             }
3676 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3677             }
3678             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3679             }
3680              
3681 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3682 416         805 elsif (/\G (\{) /oxgc) { # q { }
3683 416         799 my $q_string = '';
3684 416 50       1243 local $nest = 1;
  9795 50       35243  
    50          
    100          
    100          
    50          
3685 0         0 while (not /\G \z/oxgc) {
3686 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3687 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  149         223  
3688             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3689 149 100       245 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  565         1166  
3690 416         1239 elsif (/\G (\}) /oxgc) {
3691             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3692 149         368 else { $q_string .= $1; }
3693             }
3694 9081         18807 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3695             }
3696             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3697             }
3698              
3699 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3700 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3701 0         0 my $q_string = '';
3702 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3703 0         0 while (not /\G \z/oxgc) {
3704 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3705 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3706             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3707 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3708 0         0 elsif (/\G (\]) /oxgc) {
3709             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3710 0         0 else { $q_string .= $1; }
3711             }
3712 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3713             }
3714             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3715             }
3716              
3717 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3718 5         11 elsif (/\G (\<) /oxgc) { # q < >
3719 5         9 my $q_string = '';
3720 5 50       18 local $nest = 1;
  88 50       496  
    50          
    50          
    100          
    50          
3721 0         0 while (not /\G \z/oxgc) {
3722 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3723 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3724             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3725 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         17  
3726 5         14 elsif (/\G (\>) /oxgc) {
3727             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3728 0         0 else { $q_string .= $1; }
3729             }
3730 83         246 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3731             }
3732             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3733             }
3734              
3735 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3736 1         2 elsif (/\G (\S) /oxgc) { # q * *
3737 1         2 my $delimiter = $1;
3738 1 50       4 my $q_string = '';
  14 50       71  
    100          
    50          
3739 0         0 while (not /\G \z/oxgc) {
3740 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3741 1         2 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3742             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3743 13         26 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3744             }
3745             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3746 0         0 }
3747             }
3748             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3749             }
3750             }
3751              
3752 0         0 # m//
3753 209 50       480 elsif (/\G \b (m) \b /oxgc) {
3754 209         1369 my $ope = $1;
3755             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3756             return e_qr($ope,$1,$3,$2,$4);
3757 0         0 }
3758 209         433 else {
3759 209 50       534 my $e = '';
  209 50       10297  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3760 0         0 while (not /\G \z/oxgc) {
3761 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3762 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3763 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3764 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3765 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3766 10         38 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3767 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3768             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3769 199         680 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3770             }
3771             die __FILE__, ": Search pattern not terminated\n";
3772             }
3773             }
3774              
3775             # s///
3776              
3777             # about [cegimosxpradlunbB]* (/cg modifier)
3778             #
3779             # P.67 Pattern-Matching Operators
3780             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3781 0         0  
3782             elsif (/\G \b (s) \b /oxgc) {
3783             my $ope = $1;
3784 97 100       267  
3785 97         2926 # $1 $2 $3 $4 $5 $6
3786             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3787             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3788 1         4 }
3789 96         189 else {
3790 96 50       303 my $e = '';
  96 50       13231  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3791             while (not /\G \z/oxgc) {
3792 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3793 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3794 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3795             while (not /\G \z/oxgc) {
3796 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3797 0         0 # $1 $2 $3 $4
3798 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3799 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3800 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3801 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3802 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3803 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3804 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3805             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3806 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3807             }
3808             die __FILE__, ": Substitution replacement not terminated\n";
3809 0         0 }
3810 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3811 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3812             while (not /\G \z/oxgc) {
3813 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3814 0         0 # $1 $2 $3 $4
3815 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3816 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3817 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3818 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3819 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3820 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3821 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3822             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3823 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3824             }
3825             die __FILE__, ": Substitution replacement not terminated\n";
3826 0         0 }
3827 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3828 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3829             while (not /\G \z/oxgc) {
3830 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3831 0         0 # $1 $2 $3 $4
3832 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3833 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3834 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3835 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3836 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3837             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3838 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3839             }
3840             die __FILE__, ": Substitution replacement not terminated\n";
3841 0         0 }
3842 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3843 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3844             while (not /\G \z/oxgc) {
3845 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3846 0         0 # $1 $2 $3 $4
3847 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3848 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3849 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3850 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3851 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3852 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3853 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3854             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3855 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3856             }
3857             die __FILE__, ": Substitution replacement not terminated\n";
3858             }
3859 0         0 # $1 $2 $3 $4 $5 $6
3860             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3861             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3862             }
3863 21         76 # $1 $2 $3 $4 $5 $6
3864             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3865             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3866             }
3867 0         0 # $1 $2 $3 $4 $5 $6
3868             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3869             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3870             }
3871 0         0 # $1 $2 $3 $4 $5 $6
3872             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3873             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3874 75         338 }
3875             }
3876             die __FILE__, ": Substitution pattern not terminated\n";
3877             }
3878             }
3879 0         0  
3880 0         0 # require ignore module
3881 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3882             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3883             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3884 0         0  
3885 37         406 # use strict; --> use strict; no strict qw(refs);
3886 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3887             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
3888             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
3889              
3890 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
3891 2         19 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
3892             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
3893             return "use $1; no strict qw(refs);";
3894 0         0 }
3895             else {
3896             return "use $1;";
3897             }
3898 2 0 0     11 }
      0        
3899 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
3900             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
3901             return "use $1; no strict qw(refs);";
3902 0         0 }
3903             else {
3904             return "use $1;";
3905             }
3906             }
3907 0         0  
3908 2         14 # ignore use module
3909 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
3910             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
3911             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
3912 0         0  
3913 0         0 # ignore no module
3914 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
3915             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
3916             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
3917 0         0  
3918             # use else
3919             elsif (/\G \b use \b /oxmsgc) { return "use"; }
3920 0         0  
3921             # use else
3922             elsif (/\G \b no \b /oxmsgc) { return "no"; }
3923              
3924 2         11 # ''
3925 836         1806 elsif (/\G (?
3926 836 100       2144 my $q_string = '';
  9499 100       29821  
    100          
    50          
3927 4         10 while (not /\G \z/oxgc) {
3928 12         24 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3929 836         1837 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
3930             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
3931 8647         17081 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3932             }
3933             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3934             }
3935              
3936 0         0 # ""
3937 1552         3173 elsif (/\G (\") /oxgc) {
3938 1552 100       5251 my $qq_string = '';
  36223 100       110003  
    100          
    50          
3939 67         155 while (not /\G \z/oxgc) {
3940 12         74 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3941 1552         4874 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
3942             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
3943 34592         86990 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3944             }
3945             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3946             }
3947              
3948 0         0 # ``
3949 1         3 elsif (/\G (\`) /oxgc) {
3950 1 50       4 my $qx_string = '';
  19 50       70  
    100          
    50          
3951 0         0 while (not /\G \z/oxgc) {
3952 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
3953 1         4 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
3954             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
3955 18         39 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
3956             }
3957             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3958             }
3959              
3960 0         0 # // --- not divide operator (num / num), not defined-or
3961 425         977 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
3962 425 50       1178 my $regexp = '';
  4222 50       26952  
    100          
    50          
3963 0         0 while (not /\G \z/oxgc) {
3964 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3965 425         1148 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
3966             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
3967 3797         9248 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3968             }
3969             die __FILE__, ": Search pattern not terminated\n";
3970             }
3971              
3972 0         0 # ?? --- not conditional operator (condition ? then : else)
3973 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
3974 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
3975 0         0 while (not /\G \z/oxgc) {
3976 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3977 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
3978             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
3979 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3980             }
3981             die __FILE__, ": Search pattern not terminated\n";
3982             }
3983 0         0  
  0         0  
3984             # <<>> (a safer ARGV)
3985             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
3986 0         0  
  0         0  
3987             # << (bit shift) --- not here document
3988             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
3989              
3990 0         0 # <<~'HEREDOC'
3991 6         14 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
3992 6         13 $slash = 'm//';
3993             my $here_quote = $1;
3994             my $delimiter = $2;
3995 6 50       12  
3996 6         16 # get here document
3997 6         41 if ($here_script eq '') {
3998             $here_script = CORE::substr $_, pos $_;
3999 6 50       37 $here_script =~ s/.*?\n//oxm;
4000 6         69 }
4001 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4002 6         10 my $heredoc = $1;
4003 6         57 my $indent = $2;
4004 6         22 $heredoc =~ s{^$indent}{}msg; # no /ox
4005             push @heredoc, $heredoc . qq{\n$delimiter\n};
4006             push @heredoc_delimiter, qq{\\s*$delimiter};
4007 6         15 }
4008             else {
4009 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4010             }
4011             return qq{<<'$delimiter'};
4012             }
4013              
4014             # <<~\HEREDOC
4015              
4016             # P.66 2.6.6. "Here" Documents
4017             # in Chapter 2: Bits and Pieces
4018             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4019              
4020             # P.73 "Here" Documents
4021             # in Chapter 2: Bits and Pieces
4022             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4023 6         25  
4024 3         6 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4025 3         9 $slash = 'm//';
4026             my $here_quote = $1;
4027             my $delimiter = $2;
4028 3 50       7  
4029 3         10 # get here document
4030 3         25 if ($here_script eq '') {
4031             $here_script = CORE::substr $_, pos $_;
4032 3 50       19 $here_script =~ s/.*?\n//oxm;
4033 3         46 }
4034 3         10 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4035 3         4 my $heredoc = $1;
4036 3         39 my $indent = $2;
4037 3         12 $heredoc =~ s{^$indent}{}msg; # no /ox
4038             push @heredoc, $heredoc . qq{\n$delimiter\n};
4039             push @heredoc_delimiter, qq{\\s*$delimiter};
4040 3         9 }
4041             else {
4042 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4043             }
4044             return qq{<<\\$delimiter};
4045             }
4046              
4047 3         13 # <<~"HEREDOC"
4048 6         12 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4049 6         13 $slash = 'm//';
4050             my $here_quote = $1;
4051             my $delimiter = $2;
4052 6 50       10  
4053 6         13 # get here document
4054 6         21 if ($here_script eq '') {
4055             $here_script = CORE::substr $_, pos $_;
4056 6 50       32 $here_script =~ s/.*?\n//oxm;
4057 6         67 }
4058 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4059 6         7 my $heredoc = $1;
4060 6         54 my $indent = $2;
4061 6         292 $heredoc =~ s{^$indent}{}msg; # no /ox
4062             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4063             push @heredoc_delimiter, qq{\\s*$delimiter};
4064 6         20 }
4065             else {
4066 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4067             }
4068             return qq{<<"$delimiter"};
4069             }
4070              
4071 6         25 # <<~HEREDOC
4072 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4073 3         18 $slash = 'm//';
4074             my $here_quote = $1;
4075             my $delimiter = $2;
4076 3 50       8  
4077 3         10 # get here document
4078 3         19 if ($here_script eq '') {
4079             $here_script = CORE::substr $_, pos $_;
4080 3 50       26 $here_script =~ s/.*?\n//oxm;
4081 3         42 }
4082 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4083 3         44 my $heredoc = $1;
4084 3         43 my $indent = $2;
4085 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
4086             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4087             push @heredoc_delimiter, qq{\\s*$delimiter};
4088 3         81 }
4089             else {
4090 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4091             }
4092             return qq{<<$delimiter};
4093             }
4094              
4095 3         18 # <<~`HEREDOC`
4096 6         11 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4097 6         11 $slash = 'm//';
4098             my $here_quote = $1;
4099             my $delimiter = $2;
4100 6 50       10  
4101 6         10 # get here document
4102 6         18 if ($here_script eq '') {
4103             $here_script = CORE::substr $_, pos $_;
4104 6 50       41 $here_script =~ s/.*?\n//oxm;
4105 6         55 }
4106 6         12 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4107 6         8 my $heredoc = $1;
4108 6         57 my $indent = $2;
4109 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
4110             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4111             push @heredoc_delimiter, qq{\\s*$delimiter};
4112 6         10 }
4113             else {
4114 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4115             }
4116             return qq{<<`$delimiter`};
4117             }
4118              
4119 6         24 # <<'HEREDOC'
4120 72         475 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4121 72         152 $slash = 'm//';
4122             my $here_quote = $1;
4123             my $delimiter = $2;
4124 72 50       123  
4125 72         205 # get here document
4126 72         410 if ($here_script eq '') {
4127             $here_script = CORE::substr $_, pos $_;
4128 72 50       490 $here_script =~ s/.*?\n//oxm;
4129 72         638 }
4130 72         260 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4131             push @heredoc, $1 . qq{\n$delimiter\n};
4132             push @heredoc_delimiter, $delimiter;
4133 72         133 }
4134             else {
4135 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4136             }
4137             return $here_quote;
4138             }
4139              
4140             # <<\HEREDOC
4141              
4142             # P.66 2.6.6. "Here" Documents
4143             # in Chapter 2: Bits and Pieces
4144             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4145              
4146             # P.73 "Here" Documents
4147             # in Chapter 2: Bits and Pieces
4148             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4149 72         273  
4150 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4151 0         0 $slash = 'm//';
4152             my $here_quote = $1;
4153             my $delimiter = $2;
4154 0 0       0  
4155 0         0 # get here document
4156 0         0 if ($here_script eq '') {
4157             $here_script = CORE::substr $_, pos $_;
4158 0 0       0 $here_script =~ s/.*?\n//oxm;
4159 0         0 }
4160 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4161             push @heredoc, $1 . qq{\n$delimiter\n};
4162             push @heredoc_delimiter, $delimiter;
4163 0         0 }
4164             else {
4165 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4166             }
4167             return $here_quote;
4168             }
4169              
4170 0         0 # <<"HEREDOC"
4171 36         90 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4172 36         87 $slash = 'm//';
4173             my $here_quote = $1;
4174             my $delimiter = $2;
4175 36 50       70  
4176 36         92 # get here document
4177 36         1450 if ($here_script eq '') {
4178             $here_script = CORE::substr $_, pos $_;
4179 36 50       239 $here_script =~ s/.*?\n//oxm;
4180 36         545 }
4181 36         123 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4182             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4183             push @heredoc_delimiter, $delimiter;
4184 36         89 }
4185             else {
4186 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4187             }
4188             return $here_quote;
4189             }
4190              
4191 36         163 # <
4192 42         104 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4193 42         113 $slash = 'm//';
4194             my $here_quote = $1;
4195             my $delimiter = $2;
4196 42 50       92  
4197 42         126 # get here document
4198 42         439 if ($here_script eq '') {
4199             $here_script = CORE::substr $_, pos $_;
4200 42 50       347 $here_script =~ s/.*?\n//oxm;
4201 42         591 }
4202 42         170 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4203             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4204             push @heredoc_delimiter, $delimiter;
4205 42         96 }
4206             else {
4207 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4208             }
4209             return $here_quote;
4210             }
4211              
4212 42         181 # <<`HEREDOC`
4213 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4214 0         0 $slash = 'm//';
4215             my $here_quote = $1;
4216             my $delimiter = $2;
4217 0 0       0  
4218 0         0 # get here document
4219 0         0 if ($here_script eq '') {
4220             $here_script = CORE::substr $_, pos $_;
4221 0 0       0 $here_script =~ s/.*?\n//oxm;
4222 0         0 }
4223 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4224             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4225             push @heredoc_delimiter, $delimiter;
4226 0         0 }
4227             else {
4228 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4229             }
4230             return $here_quote;
4231             }
4232              
4233 0         0 # <<= <=> <= < operator
4234             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4235             return $1;
4236             }
4237              
4238 12         261 #
4239             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4240             return $1;
4241             }
4242              
4243             # --- glob
4244              
4245             # avoid "Error: Runtime exception" of perl version 5.005_03
4246 0         0  
4247             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4248             return 'Eusascii::glob("' . $1 . '")';
4249             }
4250 0         0  
4251             # __DATA__
4252             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4253 0         0  
4254             # __END__
4255             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4256              
4257             # \cD Control-D
4258              
4259             # P.68 2.6.8. Other Literal Tokens
4260             # in Chapter 2: Bits and Pieces
4261             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4262              
4263             # P.76 Other Literal Tokens
4264             # in Chapter 2: Bits and Pieces
4265 204         1627 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4266              
4267             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4268 0         0  
4269             # \cZ Control-Z
4270             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4271              
4272             # any operator before div
4273             elsif (/\G (
4274             -- | \+\+ |
4275 0         0 [\)\}\]]
  5017         11810  
4276              
4277             ) /oxgc) { $slash = 'div'; return $1; }
4278              
4279             # yada-yada or triple-dot operator
4280             elsif (/\G (
4281 5017         40978 \.\.\.
  7         13  
4282              
4283             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4284              
4285             # any operator before m//
4286              
4287             # //, //= (defined-or)
4288              
4289             # P.164 Logical Operators
4290             # in Chapter 10: More Control Structures
4291             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4292              
4293             # P.119 C-Style Logical (Short-Circuit) Operators
4294             # in Chapter 3: Unary and Binary Operators
4295             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4296              
4297             # (and so on)
4298              
4299             # ~~
4300              
4301             # P.221 The Smart Match Operator
4302             # in Chapter 15: Smart Matching and given-when
4303             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4304              
4305             # P.112 Smartmatch Operator
4306             # in Chapter 3: Unary and Binary Operators
4307             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4308              
4309             # (and so on)
4310              
4311             elsif (/\G ((?>
4312              
4313             !~~ | !~ | != | ! |
4314             %= | % |
4315             &&= | && | &= | &\.= | &\. | & |
4316             -= | -> | - |
4317             :(?>\s*)= |
4318             : |
4319             <<>> |
4320             <<= | <=> | <= | < |
4321             == | => | =~ | = |
4322             >>= | >> | >= | > |
4323             \*\*= | \*\* | \*= | \* |
4324             \+= | \+ |
4325             \.\. | \.= | \. |
4326             \/\/= | \/\/ |
4327             \/= | \/ |
4328             \? |
4329             \\ |
4330             \^= | \^\.= | \^\. | \^ |
4331             \b x= |
4332             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4333             ~~ | ~\. | ~ |
4334             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4335             \b(?: print )\b |
4336              
4337 7         23 [,;\(\{\[]
  8644         17137  
4338              
4339             )) /oxgc) { $slash = 'm//'; return $1; }
4340 8644         38728  
  15320         30081  
4341             # other any character
4342             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4343              
4344 15320         88052 # system error
4345             else {
4346             die __FILE__, ": Oops, this shouldn't happen!\n";
4347             }
4348             }
4349              
4350 0     1767 0 0 # escape US-ASCII string
4351 1767         4385 sub e_string {
4352             my($string) = @_;
4353 1767         3272 my $e_string = '';
4354              
4355             local $slash = 'm//';
4356              
4357             # P.1024 Appendix W.10 Multibyte Processing
4358             # of ISBN 1-56592-224-7 CJKV Information Processing
4359 1767         4025 # (and so on)
4360              
4361             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4362 1767 100 66     14234  
4363 1767 50       7890 # without { ... }
4364 1751         3838 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4365             if ($string !~ /<
4366             return $string;
4367             }
4368             }
4369 1751         4243  
4370 16 50       44 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          
4371             while ($string !~ /\G \z/oxgc) {
4372             if (0) {
4373             }
4374 185         10119  
4375 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Eusascii::PREMATCH()]}
4376 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4377             $e_string .= q{Eusascii::PREMATCH()};
4378             $slash = 'div';
4379             }
4380              
4381 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Eusascii::MATCH()]}
4382 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4383             $e_string .= q{Eusascii::MATCH()};
4384             $slash = 'div';
4385             }
4386              
4387 0         0 # $', ${'} --> $', ${'}
4388 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4389             $e_string .= $1;
4390             $slash = 'div';
4391             }
4392              
4393 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Eusascii::POSTMATCH()]}
4394 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4395             $e_string .= q{Eusascii::POSTMATCH()};
4396             $slash = 'div';
4397             }
4398              
4399 0         0 # bareword
4400 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4401             $e_string .= $1;
4402             $slash = 'div';
4403             }
4404              
4405 0         0 # $0 --> $0
4406 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4407             $e_string .= $1;
4408             $slash = 'div';
4409 0         0 }
4410 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4411             $e_string .= $1;
4412             $slash = 'div';
4413             }
4414              
4415 0         0 # $$ --> $$
4416 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4417             $e_string .= $1;
4418             $slash = 'div';
4419             }
4420              
4421             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4422 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4423 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4424             $e_string .= e_capture($1);
4425             $slash = 'div';
4426 0         0 }
4427 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4428             $e_string .= e_capture($1);
4429             $slash = 'div';
4430             }
4431              
4432 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4433 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4434             $e_string .= e_capture($1.'->'.$2);
4435             $slash = 'div';
4436             }
4437              
4438 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4439 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4440             $e_string .= e_capture($1.'->'.$2);
4441             $slash = 'div';
4442             }
4443              
4444 0         0 # $$foo
4445 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4446             $e_string .= e_capture($1);
4447             $slash = 'div';
4448             }
4449              
4450 0         0 # ${ foo }
4451 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4452             $e_string .= '${' . $1 . '}';
4453             $slash = 'div';
4454             }
4455              
4456 0         0 # ${ ... }
4457 3         11 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4458             $e_string .= e_capture($1);
4459             $slash = 'div';
4460             }
4461              
4462             # variable or function
4463 3         14 # $ @ % & * $ #
4464 6         16 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) {
4465             $e_string .= $1;
4466             $slash = 'div';
4467             }
4468             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4469 6         17 # $ @ # \ ' " / ? ( ) [ ] < >
4470 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4471             $e_string .= $1;
4472             $slash = 'div';
4473             }
4474 0         0  
  0         0  
4475 0         0 # subroutines of package Eusascii
  0         0  
4476 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4477 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4478 0         0 elsif ($string =~ /\G \b USASCII::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4479 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4480 0         0 elsif ($string =~ /\G \b USASCII::eval \b /oxgc) { $e_string .= 'eval USASCII::escape'; $slash = 'm//'; }
  0         0  
4481 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4482 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Eusascii::chop'; $slash = 'm//'; }
  0         0  
4483 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4484 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4485 0         0 elsif ($string =~ /\G \b USASCII::index \b /oxgc) { $e_string .= 'USASCII::index'; $slash = 'm//'; }
  0         0  
4486 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Eusascii::index'; $slash = 'm//'; }
  0         0  
4487 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4488 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4489 0         0 elsif ($string =~ /\G \b USASCII::rindex \b /oxgc) { $e_string .= 'USASCII::rindex'; $slash = 'm//'; }
  0         0  
4490 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Eusascii::rindex'; $slash = 'm//'; }
  0         0  
4491 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::lc'; $slash = 'm//'; }
  0         0  
4492 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::lcfirst'; $slash = 'm//'; }
  0         0  
4493 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::uc'; $slash = 'm//'; }
  0         0  
4494             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::ucfirst'; $slash = 'm//'; }
4495             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::fc'; $slash = 'm//'; }
4496 0         0  
  0         0  
4497 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4498 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4499 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  
4500 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  
4501 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  
4502 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  
4503             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4504 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  
4505 0         0  
  0         0  
4506 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4507 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  
4508 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  
4509 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  
4510 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  
4511             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4512             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4513 0         0  
  0         0  
4514 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4515 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4516 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4517             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4518 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4519 0         0  
  0         0  
4520 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4521 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4522 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::chr'; $slash = 'm//'; }
  0         0  
4523 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4524 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4525 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Eusascii::glob'; $slash = 'm//'; }
  0         0  
4526 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Eusascii::lc_'; $slash = 'm//'; }
  0         0  
4527 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Eusascii::lcfirst_'; $slash = 'm//'; }
  0         0  
4528 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Eusascii::uc_'; $slash = 'm//'; }
  0         0  
4529 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Eusascii::ucfirst_'; $slash = 'm//'; }
  0         0  
4530             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Eusascii::fc_'; $slash = 'm//'; }
4531 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4532 0         0  
  0         0  
4533 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4534 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4535 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Eusascii::chr_'; $slash = 'm//'; }
  0         0  
4536 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4537 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4538 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Eusascii::glob_'; $slash = 'm//'; }
  0         0  
4539             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4540             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4541 0         0 # split
4542             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4543 0         0 $slash = 'm//';
4544 0         0  
4545 0         0 my $e = '';
4546             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4547             $e .= $1;
4548             }
4549 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          
4550             # end of split
4551             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Eusascii::split' . $e; }
4552 0         0  
  0         0  
4553             # split scalar value
4554             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Eusascii::split' . $e . e_string($1); next E_STRING_LOOP; }
4555 0         0  
  0         0  
4556 0         0 # split literal space
  0         0  
4557 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4558 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4559 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4560 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4561 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4562 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  
4563 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4564 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4565 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4566 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4567 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4568 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  
4569             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {' '}; next E_STRING_LOOP; }
4570             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Eusascii::split' . $e . qq {" "}; next E_STRING_LOOP; }
4571              
4572 0 0       0 # split qq//
  0         0  
  0         0  
4573             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4574 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4575 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4576 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4577 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4578 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  
4579 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  
4580 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  
4581 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  
4582             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4583 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 * *
4584             }
4585             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4586             }
4587             }
4588              
4589 0 0       0 # split qr//
  0         0  
  0         0  
4590             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4591 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4592 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4593 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4594 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4595 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  
4596 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  
4597 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  
4598 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  
4599 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  
4600             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4601 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 * *
4602             }
4603             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4604             }
4605             }
4606              
4607 0 0       0 # split q//
  0         0  
  0         0  
4608             elsif ($string =~ /\G \b (q) \b /oxgc) {
4609 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4610 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4611 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4612 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4613 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  
4614 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  
4615 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  
4616 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  
4617             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4618 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 * *
4619             }
4620             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4621             }
4622             }
4623              
4624 0 0       0 # split m//
  0         0  
  0         0  
4625             elsif ($string =~ /\G \b (m) \b /oxgc) {
4626 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 # #
4627 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4628 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4629 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4630 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  
4631 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  
4632 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  
4633 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  
4634 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  
4635             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4636 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 * *
4637             }
4638             die __FILE__, ": Search pattern not terminated\n";
4639             }
4640             }
4641              
4642 0         0 # split ''
4643 0         0 elsif ($string =~ /\G (\') /oxgc) {
4644 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4645 0         0 while ($string !~ /\G \z/oxgc) {
4646 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4647 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4648             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4649 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4650             }
4651             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4652             }
4653              
4654 0         0 # split ""
4655 0         0 elsif ($string =~ /\G (\") /oxgc) {
4656 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4657 0         0 while ($string !~ /\G \z/oxgc) {
4658 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4659 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4660             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4661 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4662             }
4663             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4664             }
4665              
4666 0         0 # split //
4667 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4668 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4669 0         0 while ($string !~ /\G \z/oxgc) {
4670 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4671 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4672             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4673 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4674             }
4675             die __FILE__, ": Search pattern not terminated\n";
4676             }
4677             }
4678              
4679 0         0 # qq//
4680 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4681 0         0 my $ope = $1;
4682             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4683             $e_string .= e_qq($ope,$1,$3,$2);
4684 0         0 }
4685 0         0 else {
4686 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4687 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4688 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4689 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4690 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4691 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4692             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4693 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4694             }
4695             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4696             }
4697             }
4698              
4699 0         0 # qx//
4700 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4701 0         0 my $ope = $1;
4702             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4703             $e_string .= e_qq($ope,$1,$3,$2);
4704 0         0 }
4705 0         0 else {
4706 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4707 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4708 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4709 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4710 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4711 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4712 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4713             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4714 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4715             }
4716             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4717             }
4718             }
4719              
4720 0         0 # q//
4721 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4722 0         0 my $ope = $1;
4723             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4724             $e_string .= e_q($ope,$1,$3,$2);
4725 0         0 }
4726 0         0 else {
4727 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4728 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4729 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4730 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4731 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4732 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4733             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4734 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 * *
4735             }
4736             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4737             }
4738             }
4739 0         0  
4740             # ''
4741             elsif ($string =~ /\G (?
4742 0         0  
4743             # ""
4744             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4745 0         0  
4746             # ``
4747             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4748 0         0  
4749             # <<>> (a safer ARGV)
4750             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4751 0         0  
4752             # <<= <=> <= < operator
4753             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4754 0         0  
4755             #
4756             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4757              
4758 0         0 # --- glob
4759             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4760             $e_string .= 'Eusascii::glob("' . $1 . '")';
4761             }
4762              
4763 0         0 # << (bit shift) --- not here document
4764 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4765             $slash = 'm//';
4766             $e_string .= $1;
4767             }
4768              
4769 0         0 # <<~'HEREDOC'
4770 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4771 0         0 $slash = 'm//';
4772             my $here_quote = $1;
4773             my $delimiter = $2;
4774 0 0       0  
4775 0         0 # get here document
4776 0         0 if ($here_script eq '') {
4777             $here_script = CORE::substr $_, pos $_;
4778 0 0       0 $here_script =~ s/.*?\n//oxm;
4779 0         0 }
4780 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4781 0         0 my $heredoc = $1;
4782 0         0 my $indent = $2;
4783 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4784             push @heredoc, $heredoc . qq{\n$delimiter\n};
4785             push @heredoc_delimiter, qq{\\s*$delimiter};
4786 0         0 }
4787             else {
4788 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4789             }
4790             $e_string .= qq{<<'$delimiter'};
4791             }
4792              
4793 0         0 # <<~\HEREDOC
4794 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4795 0         0 $slash = 'm//';
4796             my $here_quote = $1;
4797             my $delimiter = $2;
4798 0 0       0  
4799 0         0 # get here document
4800 0         0 if ($here_script eq '') {
4801             $here_script = CORE::substr $_, pos $_;
4802 0 0       0 $here_script =~ s/.*?\n//oxm;
4803 0         0 }
4804 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4805 0         0 my $heredoc = $1;
4806 0         0 my $indent = $2;
4807 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4808             push @heredoc, $heredoc . qq{\n$delimiter\n};
4809             push @heredoc_delimiter, qq{\\s*$delimiter};
4810 0         0 }
4811             else {
4812 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4813             }
4814             $e_string .= qq{<<\\$delimiter};
4815             }
4816              
4817 0         0 # <<~"HEREDOC"
4818 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4819 0         0 $slash = 'm//';
4820             my $here_quote = $1;
4821             my $delimiter = $2;
4822 0 0       0  
4823 0         0 # get here document
4824 0         0 if ($here_script eq '') {
4825             $here_script = CORE::substr $_, pos $_;
4826 0 0       0 $here_script =~ s/.*?\n//oxm;
4827 0         0 }
4828 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4829 0         0 my $heredoc = $1;
4830 0         0 my $indent = $2;
4831 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4832             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4833             push @heredoc_delimiter, qq{\\s*$delimiter};
4834 0         0 }
4835             else {
4836 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4837             }
4838             $e_string .= qq{<<"$delimiter"};
4839             }
4840              
4841 0         0 # <<~HEREDOC
4842 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4843 0         0 $slash = 'm//';
4844             my $here_quote = $1;
4845             my $delimiter = $2;
4846 0 0       0  
4847 0         0 # get here document
4848 0         0 if ($here_script eq '') {
4849             $here_script = CORE::substr $_, pos $_;
4850 0 0       0 $here_script =~ s/.*?\n//oxm;
4851 0         0 }
4852 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4853 0         0 my $heredoc = $1;
4854 0         0 my $indent = $2;
4855 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4856             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4857             push @heredoc_delimiter, qq{\\s*$delimiter};
4858 0         0 }
4859             else {
4860 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4861             }
4862             $e_string .= qq{<<$delimiter};
4863             }
4864              
4865 0         0 # <<~`HEREDOC`
4866 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4867 0         0 $slash = 'm//';
4868             my $here_quote = $1;
4869             my $delimiter = $2;
4870 0 0       0  
4871 0         0 # get here document
4872 0         0 if ($here_script eq '') {
4873             $here_script = CORE::substr $_, pos $_;
4874 0 0       0 $here_script =~ s/.*?\n//oxm;
4875 0         0 }
4876 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4877 0         0 my $heredoc = $1;
4878 0         0 my $indent = $2;
4879 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4880             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4881             push @heredoc_delimiter, qq{\\s*$delimiter};
4882 0         0 }
4883             else {
4884 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4885             }
4886             $e_string .= qq{<<`$delimiter`};
4887             }
4888              
4889 0         0 # <<'HEREDOC'
4890 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4891 0         0 $slash = 'm//';
4892             my $here_quote = $1;
4893             my $delimiter = $2;
4894 0 0       0  
4895 0         0 # get here document
4896 0         0 if ($here_script eq '') {
4897             $here_script = CORE::substr $_, pos $_;
4898 0 0       0 $here_script =~ s/.*?\n//oxm;
4899 0         0 }
4900 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4901             push @heredoc, $1 . qq{\n$delimiter\n};
4902             push @heredoc_delimiter, $delimiter;
4903 0         0 }
4904             else {
4905 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4906             }
4907             $e_string .= $here_quote;
4908             }
4909              
4910 0         0 # <<\HEREDOC
4911 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4912 0         0 $slash = 'm//';
4913             my $here_quote = $1;
4914             my $delimiter = $2;
4915 0 0       0  
4916 0         0 # get here document
4917 0         0 if ($here_script eq '') {
4918             $here_script = CORE::substr $_, pos $_;
4919 0 0       0 $here_script =~ s/.*?\n//oxm;
4920 0         0 }
4921 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4922             push @heredoc, $1 . qq{\n$delimiter\n};
4923             push @heredoc_delimiter, $delimiter;
4924 0         0 }
4925             else {
4926 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4927             }
4928             $e_string .= $here_quote;
4929             }
4930              
4931 0         0 # <<"HEREDOC"
4932 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4933 0         0 $slash = 'm//';
4934             my $here_quote = $1;
4935             my $delimiter = $2;
4936 0 0       0  
4937 0         0 # get here document
4938 0         0 if ($here_script eq '') {
4939             $here_script = CORE::substr $_, pos $_;
4940 0 0       0 $here_script =~ s/.*?\n//oxm;
4941 0         0 }
4942 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4943             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4944             push @heredoc_delimiter, $delimiter;
4945 0         0 }
4946             else {
4947 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4948             }
4949             $e_string .= $here_quote;
4950             }
4951              
4952 0         0 # <
4953 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4954 0         0 $slash = 'm//';
4955             my $here_quote = $1;
4956             my $delimiter = $2;
4957 0 0       0  
4958 0         0 # get here document
4959 0         0 if ($here_script eq '') {
4960             $here_script = CORE::substr $_, pos $_;
4961 0 0       0 $here_script =~ s/.*?\n//oxm;
4962 0         0 }
4963 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4964             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4965             push @heredoc_delimiter, $delimiter;
4966 0         0 }
4967             else {
4968 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4969             }
4970             $e_string .= $here_quote;
4971             }
4972              
4973 0         0 # <<`HEREDOC`
4974 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4975 0         0 $slash = 'm//';
4976             my $here_quote = $1;
4977             my $delimiter = $2;
4978 0 0       0  
4979 0         0 # get here document
4980 0         0 if ($here_script eq '') {
4981             $here_script = CORE::substr $_, pos $_;
4982 0 0       0 $here_script =~ s/.*?\n//oxm;
4983 0         0 }
4984 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4985             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4986             push @heredoc_delimiter, $delimiter;
4987 0         0 }
4988             else {
4989 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4990             }
4991             $e_string .= $here_quote;
4992             }
4993              
4994             # any operator before div
4995             elsif ($string =~ /\G (
4996             -- | \+\+ |
4997 0         0 [\)\}\]]
  17         25  
4998              
4999             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5000              
5001             # yada-yada or triple-dot operator
5002             elsif ($string =~ /\G (
5003 17         50 \.\.\.
  0         0  
5004              
5005             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5006              
5007             # any operator before m//
5008             elsif ($string =~ /\G ((?>
5009              
5010             !~~ | !~ | != | ! |
5011             %= | % |
5012             &&= | && | &= | &\.= | &\. | & |
5013             -= | -> | - |
5014             :(?>\s*)= |
5015             : |
5016             <<>> |
5017             <<= | <=> | <= | < |
5018             == | => | =~ | = |
5019             >>= | >> | >= | > |
5020             \*\*= | \*\* | \*= | \* |
5021             \+= | \+ |
5022             \.\. | \.= | \. |
5023             \/\/= | \/\/ |
5024             \/= | \/ |
5025             \? |
5026             \\ |
5027             \^= | \^\.= | \^\. | \^ |
5028             \b x= |
5029             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5030             ~~ | ~\. | ~ |
5031             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5032             \b(?: print )\b |
5033              
5034 0         0 [,;\(\{\[]
  30         53  
5035              
5036             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5037 30         96  
5038             # other any character
5039             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5040              
5041 129         347 # system error
5042             else {
5043             die __FILE__, ": Oops, this shouldn't happen!\n";
5044             }
5045 0         0 }
5046              
5047             return $e_string;
5048             }
5049              
5050             #
5051             # character class
5052 16     1879 0 62 #
5053             sub character_class {
5054 1879 100       3587 my($char,$modifier) = @_;
5055 1879 100       2888  
5056 52         109 if ($char eq '.') {
5057             if ($modifier =~ /s/) {
5058             return '${Eusascii::dot_s}';
5059 17         37 }
5060             else {
5061             return '${Eusascii::dot}';
5062             }
5063 35         71 }
5064             else {
5065             return Eusascii::classic_character_class($char);
5066             }
5067             }
5068              
5069             #
5070             # escape capture ($1, $2, $3, ...)
5071             #
5072 1827     212 0 3261 sub e_capture {
5073              
5074             return join '', '${', $_[0], '}';
5075             }
5076              
5077             #
5078             # escape transliteration (tr/// or y///)
5079 212     3 0 748 #
5080 3         16 sub e_tr {
5081 3   50     4 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5082             my $e_tr = '';
5083 3         7 $modifier ||= '';
5084              
5085             $slash = 'div';
5086 3         4  
5087             # quote character class 1
5088             $charclass = q_tr($charclass);
5089 3         5  
5090             # quote character class 2
5091             $charclass2 = q_tr($charclass2);
5092 3 50       4  
5093 3 0       8 # /b /B modifier
5094 0         0 if ($modifier =~ tr/bB//d) {
5095             if ($variable eq '') {
5096             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5097 0         0 }
5098             else {
5099             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5100             }
5101 0 100       0 }
5102 3         6 else {
5103             if ($variable eq '') {
5104             $e_tr = qq{Eusascii::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5105 2         6 }
5106             else {
5107             $e_tr = qq{Eusascii::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5108             }
5109             }
5110 1         4  
5111 3         3 # clear tr/// variable
5112             $tr_variable = '';
5113 3         4 $bind_operator = '';
5114              
5115             return $e_tr;
5116             }
5117              
5118             #
5119             # quote for escape transliteration (tr/// or y///)
5120 3     6 0 17 #
5121             sub q_tr {
5122             my($charclass) = @_;
5123 6 50       8  
    0          
    0          
    0          
    0          
    0          
5124 6         37 # quote character class
5125             if ($charclass !~ /'/oxms) {
5126             return e_q('', "'", "'", $charclass); # --> q' '
5127 6         10 }
5128             elsif ($charclass !~ /\//oxms) {
5129             return e_q('q', '/', '/', $charclass); # --> q/ /
5130 0         0 }
5131             elsif ($charclass !~ /\#/oxms) {
5132             return e_q('q', '#', '#', $charclass); # --> q# #
5133 0         0 }
5134             elsif ($charclass !~ /[\<\>]/oxms) {
5135             return e_q('q', '<', '>', $charclass); # --> q< >
5136 0         0 }
5137             elsif ($charclass !~ /[\(\)]/oxms) {
5138             return e_q('q', '(', ')', $charclass); # --> q( )
5139 0         0 }
5140             elsif ($charclass !~ /[\{\}]/oxms) {
5141             return e_q('q', '{', '}', $charclass); # --> q{ }
5142 0         0 }
5143 0 0       0 else {
5144 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5145             if ($charclass !~ /\Q$char\E/xms) {
5146             return e_q('q', $char, $char, $charclass);
5147             }
5148             }
5149 0         0 }
5150              
5151             return e_q('q', '{', '}', $charclass);
5152             }
5153              
5154             #
5155             # escape q string (q//, '')
5156 0     1264 0 0 #
5157             sub e_q {
5158 1264         3075 my($ope,$delimiter,$end_delimiter,$string) = @_;
5159              
5160 1264         2312 $slash = 'div';
5161              
5162             return join '', $ope, $delimiter, $string, $end_delimiter;
5163             }
5164              
5165             #
5166             # escape qq string (qq//, "", qx//, ``)
5167 1264     3770 0 6694 #
5168             sub e_qq {
5169 3770         10073 my($ope,$delimiter,$end_delimiter,$string) = @_;
5170              
5171 3770         5163 $slash = 'div';
5172 3770         5009  
5173             my $left_e = 0;
5174             my $right_e = 0;
5175 3770         4174  
5176             # split regexp
5177             my @char = $string =~ /\G((?>
5178             [^\\\$] |
5179             \\x\{ (?>[0-9A-Fa-f]+) \} |
5180             \\o\{ (?>[0-7]+) \} |
5181             \\N\{ (?>[^0-9\}][^\}]*) \} |
5182             \\ $q_char |
5183             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5184             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5185             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5186             \$ (?>\s* [0-9]+) |
5187             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5188             \$ \$ (?![\w\{]) |
5189             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5190             $q_char
5191 3770         152221 ))/oxmsg;
5192              
5193             for (my $i=0; $i <= $#char; $i++) {
5194 3770 50 33     12738  
    50 33        
    100          
    100          
    50          
5195 114739         377196 # "\L\u" --> "\u\L"
5196             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5197             @char[$i,$i+1] = @char[$i+1,$i];
5198             }
5199              
5200 0         0 # "\U\l" --> "\l\U"
5201             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5202             @char[$i,$i+1] = @char[$i+1,$i];
5203             }
5204              
5205 0         0 # octal escape sequence
5206             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5207             $char[$i] = Eusascii::octchr($1);
5208             }
5209              
5210 1         4 # hexadecimal escape sequence
5211             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5212             $char[$i] = Eusascii::hexchr($1);
5213             }
5214              
5215 1         4 # \N{CHARNAME} --> N{CHARNAME}
5216             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5217             $char[$i] = $1;
5218 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          
5219              
5220             if (0) {
5221             }
5222              
5223             # \F
5224             #
5225             # P.69 Table 2-6. Translation escapes
5226             # in Chapter 2: Bits and Pieces
5227             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5228             # (and so on)
5229 114739         1069813  
5230 0 50       0 # \u \l \U \L \F \Q \E
5231 484         1026 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5232             if ($right_e < $left_e) {
5233             $char[$i] = '\\' . $char[$i];
5234             }
5235             }
5236             elsif ($char[$i] eq '\u') {
5237              
5238             # "STRING @{[ LIST EXPR ]} MORE STRING"
5239              
5240             # P.257 Other Tricks You Can Do with Hard References
5241             # in Chapter 8: References
5242             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5243              
5244             # P.353 Other Tricks You Can Do with Hard References
5245             # in Chapter 8: References
5246             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5247              
5248 0         0 # (and so on)
5249 0         0  
5250             $char[$i] = '@{[Eusascii::ucfirst qq<';
5251             $left_e++;
5252 0         0 }
5253 0         0 elsif ($char[$i] eq '\l') {
5254             $char[$i] = '@{[Eusascii::lcfirst qq<';
5255             $left_e++;
5256 0         0 }
5257 0         0 elsif ($char[$i] eq '\U') {
5258             $char[$i] = '@{[Eusascii::uc qq<';
5259             $left_e++;
5260 0         0 }
5261 0         0 elsif ($char[$i] eq '\L') {
5262             $char[$i] = '@{[Eusascii::lc qq<';
5263             $left_e++;
5264 0         0 }
5265 8         10 elsif ($char[$i] eq '\F') {
5266             $char[$i] = '@{[Eusascii::fc qq<';
5267             $left_e++;
5268 8         16 }
5269 0         0 elsif ($char[$i] eq '\Q') {
5270             $char[$i] = '@{[CORE::quotemeta qq<';
5271             $left_e++;
5272 0 50       0 }
5273 8         9 elsif ($char[$i] eq '\E') {
5274 8         11 if ($right_e < $left_e) {
5275             $char[$i] = '>]}';
5276             $right_e++;
5277 8         14 }
5278             else {
5279             $char[$i] = '';
5280             }
5281 0         0 }
5282 0 0       0 elsif ($char[$i] eq '\Q') {
5283 0         0 while (1) {
5284             if (++$i > $#char) {
5285 0 0       0 last;
5286 0         0 }
5287             if ($char[$i] eq '\E') {
5288             last;
5289             }
5290             }
5291             }
5292             elsif ($char[$i] eq '\E') {
5293             }
5294              
5295             # $0 --> $0
5296             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5297             }
5298             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5299             }
5300              
5301             # $$ --> $$
5302             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5303             }
5304              
5305             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5306 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5307             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5308             $char[$i] = e_capture($1);
5309 205         404 }
5310             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5311             $char[$i] = e_capture($1);
5312             }
5313              
5314 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5315             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5316             $char[$i] = e_capture($1.'->'.$2);
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_brace)*? \} ) \z/oxms) {
5321             $char[$i] = e_capture($1.'->'.$2);
5322             }
5323              
5324 0         0 # $$foo
5325             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5326             $char[$i] = e_capture($1);
5327             }
5328              
5329 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
5330             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5331             $char[$i] = '@{[Eusascii::PREMATCH()]}';
5332             }
5333              
5334 44         119 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
5335             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5336             $char[$i] = '@{[Eusascii::MATCH()]}';
5337             }
5338              
5339 45         118 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
5340             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5341             $char[$i] = '@{[Eusascii::POSTMATCH()]}';
5342             }
5343              
5344             # ${ foo } --> ${ foo }
5345             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5346             }
5347              
5348 33         87 # ${ ... }
5349             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5350             $char[$i] = e_capture($1);
5351             }
5352             }
5353 0 50       0  
5354 3770         7483 # return string
5355             if ($left_e > $right_e) {
5356 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5357             }
5358             return join '', $ope, $delimiter, @char, $end_delimiter;
5359             }
5360              
5361             #
5362             # escape qw string (qw//)
5363 3770     14 0 34599 #
5364             sub e_qw {
5365 14         72 my($ope,$delimiter,$end_delimiter,$string) = @_;
5366              
5367             $slash = 'div';
5368 14         27  
  14         164  
5369 381 50       572 # choice again delimiter
    0          
    0          
    0          
    0          
5370 14         79 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5371             if (not $octet{$end_delimiter}) {
5372             return join '', $ope, $delimiter, $string, $end_delimiter;
5373 14         115 }
5374             elsif (not $octet{')'}) {
5375             return join '', $ope, '(', $string, ')';
5376 0         0 }
5377             elsif (not $octet{'}'}) {
5378             return join '', $ope, '{', $string, '}';
5379 0         0 }
5380             elsif (not $octet{']'}) {
5381             return join '', $ope, '[', $string, ']';
5382 0         0 }
5383             elsif (not $octet{'>'}) {
5384             return join '', $ope, '<', $string, '>';
5385 0         0 }
5386 0 0       0 else {
5387 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5388             if (not $octet{$char}) {
5389             return join '', $ope, $char, $string, $char;
5390             }
5391             }
5392             }
5393 0         0  
5394 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5395 0         0 my @string = CORE::split(/\s+/, $string);
5396 0         0 for my $string (@string) {
5397 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5398 0         0 for my $octet (@octet) {
5399             if ($octet =~ /\A (['\\]) \z/oxms) {
5400             $octet = '\\' . $1;
5401 0         0 }
5402             }
5403 0         0 $string = join '', @octet;
  0         0  
5404             }
5405             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5406             }
5407              
5408             #
5409             # escape here document (<<"HEREDOC", <
5410 0     93 0 0 #
5411             sub e_heredoc {
5412 93         256 my($string) = @_;
5413              
5414 93         159 $slash = 'm//';
5415              
5416 93         469 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5417 93         161  
5418             my $left_e = 0;
5419             my $right_e = 0;
5420 93         126  
5421             # split regexp
5422             my @char = $string =~ /\G((?>
5423             [^\\\$] |
5424             \\x\{ (?>[0-9A-Fa-f]+) \} |
5425             \\o\{ (?>[0-7]+) \} |
5426             \\N\{ (?>[^0-9\}][^\}]*) \} |
5427             \\ $q_char |
5428             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5429             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5430             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5431             \$ (?>\s* [0-9]+) |
5432             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5433             \$ \$ (?![\w\{]) |
5434             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5435             $q_char
5436 93         9567 ))/oxmsg;
5437              
5438             for (my $i=0; $i <= $#char; $i++) {
5439 93 50 33     421  
    50 33        
    100          
    100          
    50          
5440 5515         17767 # "\L\u" --> "\u\L"
5441             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5442             @char[$i,$i+1] = @char[$i+1,$i];
5443             }
5444              
5445 0         0 # "\U\l" --> "\l\U"
5446             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5447             @char[$i,$i+1] = @char[$i+1,$i];
5448             }
5449              
5450 0         0 # octal escape sequence
5451             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5452             $char[$i] = Eusascii::octchr($1);
5453             }
5454              
5455 1         3 # hexadecimal escape sequence
5456             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5457             $char[$i] = Eusascii::hexchr($1);
5458             }
5459              
5460 1         3 # \N{CHARNAME} --> N{CHARNAME}
5461             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5462             $char[$i] = $1;
5463 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          
5464              
5465             if (0) {
5466             }
5467 5515         50455  
5468 0 0       0 # \u \l \U \L \F \Q \E
5469 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5470             if ($right_e < $left_e) {
5471             $char[$i] = '\\' . $char[$i];
5472             }
5473 0         0 }
5474 0         0 elsif ($char[$i] eq '\u') {
5475             $char[$i] = '@{[Eusascii::ucfirst qq<';
5476             $left_e++;
5477 0         0 }
5478 0         0 elsif ($char[$i] eq '\l') {
5479             $char[$i] = '@{[Eusascii::lcfirst qq<';
5480             $left_e++;
5481 0         0 }
5482 0         0 elsif ($char[$i] eq '\U') {
5483             $char[$i] = '@{[Eusascii::uc qq<';
5484             $left_e++;
5485 0         0 }
5486 0         0 elsif ($char[$i] eq '\L') {
5487             $char[$i] = '@{[Eusascii::lc qq<';
5488             $left_e++;
5489 0         0 }
5490 0         0 elsif ($char[$i] eq '\F') {
5491             $char[$i] = '@{[Eusascii::fc qq<';
5492             $left_e++;
5493 0         0 }
5494 0         0 elsif ($char[$i] eq '\Q') {
5495             $char[$i] = '@{[CORE::quotemeta qq<';
5496             $left_e++;
5497 0 0       0 }
5498 0         0 elsif ($char[$i] eq '\E') {
5499 0         0 if ($right_e < $left_e) {
5500             $char[$i] = '>]}';
5501             $right_e++;
5502 0         0 }
5503             else {
5504             $char[$i] = '';
5505             }
5506 0         0 }
5507 0 0       0 elsif ($char[$i] eq '\Q') {
5508 0         0 while (1) {
5509             if (++$i > $#char) {
5510 0 0       0 last;
5511 0         0 }
5512             if ($char[$i] eq '\E') {
5513             last;
5514             }
5515             }
5516             }
5517             elsif ($char[$i] eq '\E') {
5518             }
5519              
5520             # $0 --> $0
5521             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5522             }
5523             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5524             }
5525              
5526             # $$ --> $$
5527             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5528             }
5529              
5530             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5531 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5532             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5533             $char[$i] = e_capture($1);
5534 0         0 }
5535             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5536             $char[$i] = e_capture($1);
5537             }
5538              
5539 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5540             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5541             $char[$i] = e_capture($1.'->'.$2);
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_brace)*? \} ) \z/oxms) {
5546             $char[$i] = e_capture($1.'->'.$2);
5547             }
5548              
5549 0         0 # $$foo
5550             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5551             $char[$i] = e_capture($1);
5552             }
5553              
5554 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
5555             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5556             $char[$i] = '@{[Eusascii::PREMATCH()]}';
5557             }
5558              
5559 8         50 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
5560             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5561             $char[$i] = '@{[Eusascii::MATCH()]}';
5562             }
5563              
5564 8         48 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
5565             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5566             $char[$i] = '@{[Eusascii::POSTMATCH()]}';
5567             }
5568              
5569             # ${ foo } --> ${ foo }
5570             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5571             }
5572              
5573 6         31 # ${ ... }
5574             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5575             $char[$i] = e_capture($1);
5576             }
5577             }
5578 0 50       0  
5579 93         202 # return string
5580             if ($left_e > $right_e) {
5581 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5582             }
5583             return join '', @char;
5584             }
5585              
5586             #
5587             # escape regexp (m//, qr//)
5588 93     624 0 955 #
5589 624   100     2948 sub e_qr {
5590             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5591 624         2575 $modifier ||= '';
5592 624 50       1068  
5593 624         2666 $modifier =~ tr/p//d;
5594 0         0 if ($modifier =~ /([adlu])/oxms) {
5595 0 0       0 my $line = 0;
5596 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5597 0         0 if ($filename ne __FILE__) {
5598             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5599             last;
5600 0         0 }
5601             }
5602             die qq{Unsupported modifier "$1" used at line $line.\n};
5603 0         0 }
5604              
5605             $slash = 'div';
5606 624 100       1200  
    100          
5607 624         3151 # literal null string pattern
5608 8         11 if ($string eq '') {
5609 8         9 $modifier =~ tr/bB//d;
5610             $modifier =~ tr/i//d;
5611             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5612             }
5613              
5614             # /b /B modifier
5615             elsif ($modifier =~ tr/bB//d) {
5616 8 50       39  
5617 2         6 # choice again delimiter
5618 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5619 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5620 0         0 my %octet = map {$_ => 1} @char;
5621 0         0 if (not $octet{')'}) {
5622             $delimiter = '(';
5623             $end_delimiter = ')';
5624 0         0 }
5625 0         0 elsif (not $octet{'}'}) {
5626             $delimiter = '{';
5627             $end_delimiter = '}';
5628 0         0 }
5629 0         0 elsif (not $octet{']'}) {
5630             $delimiter = '[';
5631             $end_delimiter = ']';
5632 0         0 }
5633 0         0 elsif (not $octet{'>'}) {
5634             $delimiter = '<';
5635             $end_delimiter = '>';
5636 0         0 }
5637 0 0       0 else {
5638 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5639 0         0 if (not $octet{$char}) {
5640 0         0 $delimiter = $char;
5641             $end_delimiter = $char;
5642             last;
5643             }
5644             }
5645             }
5646 0 50 33     0 }
5647 2         12  
5648             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5649             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5650 0         0 }
5651             else {
5652             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5653             }
5654 2 100       11 }
5655 614         1384  
5656             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5657             my $metachar = qr/[\@\\|[\]{^]/oxms;
5658 614         2284  
5659             # split regexp
5660             my @char = $string =~ /\G((?>
5661             [^\\\$\@\[\(] |
5662             \\x (?>[0-9A-Fa-f]{1,2}) |
5663             \\ (?>[0-7]{2,3}) |
5664             \\c [\x40-\x5F] |
5665             \\x\{ (?>[0-9A-Fa-f]+) \} |
5666             \\o\{ (?>[0-7]+) \} |
5667             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5668             \\ $q_char |
5669             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5670             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5671             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5672             [\$\@] $qq_variable |
5673             \$ (?>\s* [0-9]+) |
5674             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5675             \$ \$ (?![\w\{]) |
5676             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5677             \[\^ |
5678             \[\: (?>[a-z]+) :\] |
5679             \[\:\^ (?>[a-z]+) :\] |
5680             \(\? |
5681             $q_char
5682             ))/oxmsg;
5683 614 50       72464  
5684 614         2863 # choice again delimiter
  0         0  
5685 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5686 0         0 my %octet = map {$_ => 1} @char;
5687 0         0 if (not $octet{')'}) {
5688             $delimiter = '(';
5689             $end_delimiter = ')';
5690 0         0 }
5691 0         0 elsif (not $octet{'}'}) {
5692             $delimiter = '{';
5693             $end_delimiter = '}';
5694 0         0 }
5695 0         0 elsif (not $octet{']'}) {
5696             $delimiter = '[';
5697             $end_delimiter = ']';
5698 0         0 }
5699 0         0 elsif (not $octet{'>'}) {
5700             $delimiter = '<';
5701             $end_delimiter = '>';
5702 0         0 }
5703 0 0       0 else {
5704 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5705 0         0 if (not $octet{$char}) {
5706 0         0 $delimiter = $char;
5707             $end_delimiter = $char;
5708             last;
5709             }
5710             }
5711             }
5712 0         0 }
5713 614         903  
5714 614         913 my $left_e = 0;
5715             my $right_e = 0;
5716             for (my $i=0; $i <= $#char; $i++) {
5717 614 50 66     1634  
    50 66        
    100          
    100          
    100          
    100          
5718 1820         10022 # "\L\u" --> "\u\L"
5719             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5720             @char[$i,$i+1] = @char[$i+1,$i];
5721             }
5722              
5723 0         0 # "\U\l" --> "\l\U"
5724             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5725             @char[$i,$i+1] = @char[$i+1,$i];
5726             }
5727              
5728 0         0 # octal escape sequence
5729             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5730             $char[$i] = Eusascii::octchr($1);
5731             }
5732              
5733 1         4 # hexadecimal escape sequence
5734             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5735             $char[$i] = Eusascii::hexchr($1);
5736             }
5737              
5738             # \b{...} --> b\{...}
5739             # \B{...} --> B\{...}
5740             # \N{CHARNAME} --> N\{CHARNAME}
5741             # \p{PROPERTY} --> p\{PROPERTY}
5742 1         3 # \P{PROPERTY} --> P\{PROPERTY}
5743             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5744             $char[$i] = $1 . '\\' . $2;
5745             }
5746              
5747 6         24 # \p, \P, \X --> p, P, X
5748             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5749             $char[$i] = $1;
5750 4 100 100     12 }
    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          
5751              
5752             if (0) {
5753             }
5754 1820         5622  
5755 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5756 6         75 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5757             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)) {
5758             $char[$i] .= join '', splice @char, $i+1, 3;
5759 0         0 }
5760             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)) {
5761             $char[$i] .= join '', splice @char, $i+1, 2;
5762 0         0 }
5763             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)) {
5764             $char[$i] .= join '', splice @char, $i+1, 1;
5765             }
5766             }
5767              
5768 0         0 # open character class [...]
5769             elsif ($char[$i] eq '[') {
5770             my $left = $i;
5771              
5772             # [] make die "Unmatched [] in regexp ...\n"
5773 316 100       409 # (and so on)
5774 316         779  
5775             if ($char[$i+1] eq ']') {
5776             $i++;
5777 3         3 }
5778 316 50       453  
5779 1343         1964 while (1) {
5780             if (++$i > $#char) {
5781 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5782 1343         2286 }
5783             if ($char[$i] eq ']') {
5784             my $right = $i;
5785 316 100       427  
5786 316         1567 # [...]
  30         75  
5787             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5788             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);
5789 90         145 }
5790             else {
5791             splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
5792 286         2216 }
5793 316         590  
5794             $i = $left;
5795             last;
5796             }
5797             }
5798             }
5799              
5800 316         1234 # open character class [^...]
5801             elsif ($char[$i] eq '[^') {
5802             my $left = $i;
5803              
5804             # [^] make die "Unmatched [] in regexp ...\n"
5805 74 100       105 # (and so on)
5806 74         215  
5807             if ($char[$i+1] eq ']') {
5808             $i++;
5809 4         8 }
5810 74 50       95  
5811 272         410 while (1) {
5812             if (++$i > $#char) {
5813 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5814 272         412 }
5815             if ($char[$i] eq ']') {
5816             my $right = $i;
5817 74 100       91  
5818 74         420 # [^...]
  30         73  
5819             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5820             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);
5821 90         151 }
5822             else {
5823             splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5824 44         200 }
5825 74         141  
5826             $i = $left;
5827             last;
5828             }
5829             }
5830             }
5831              
5832 74         203 # rewrite character class or escape character
5833             elsif (my $char = character_class($char[$i],$modifier)) {
5834             $char[$i] = $char;
5835             }
5836              
5837 139 50       353 # /i modifier
5838 20         60 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
5839             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
5840             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
5841 20         31 }
5842             else {
5843             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
5844             }
5845             }
5846              
5847 0 50       0 # \u \l \U \L \F \Q \E
5848 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5849             if ($right_e < $left_e) {
5850             $char[$i] = '\\' . $char[$i];
5851             }
5852 0         0 }
5853 0         0 elsif ($char[$i] eq '\u') {
5854             $char[$i] = '@{[Eusascii::ucfirst qq<';
5855             $left_e++;
5856 0         0 }
5857 0         0 elsif ($char[$i] eq '\l') {
5858             $char[$i] = '@{[Eusascii::lcfirst qq<';
5859             $left_e++;
5860 0         0 }
5861 1         2 elsif ($char[$i] eq '\U') {
5862             $char[$i] = '@{[Eusascii::uc qq<';
5863             $left_e++;
5864 1         3 }
5865 1         3 elsif ($char[$i] eq '\L') {
5866             $char[$i] = '@{[Eusascii::lc qq<';
5867             $left_e++;
5868 1         3 }
5869 6         10 elsif ($char[$i] eq '\F') {
5870             $char[$i] = '@{[Eusascii::fc qq<';
5871             $left_e++;
5872 6         13 }
5873 1         4 elsif ($char[$i] eq '\Q') {
5874             $char[$i] = '@{[CORE::quotemeta qq<';
5875             $left_e++;
5876 1 50       3 }
5877 9         19 elsif ($char[$i] eq '\E') {
5878 9         12 if ($right_e < $left_e) {
5879             $char[$i] = '>]}';
5880             $right_e++;
5881 9         19 }
5882             else {
5883             $char[$i] = '';
5884             }
5885 0         0 }
5886 0 0       0 elsif ($char[$i] eq '\Q') {
5887 0         0 while (1) {
5888             if (++$i > $#char) {
5889 0 0       0 last;
5890 0         0 }
5891             if ($char[$i] eq '\E') {
5892             last;
5893             }
5894             }
5895             }
5896             elsif ($char[$i] eq '\E') {
5897             }
5898              
5899 0 0       0 # $0 --> $0
5900 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5901             if ($ignorecase) {
5902             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5903             }
5904 0 0       0 }
5905 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5906             if ($ignorecase) {
5907             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5908             }
5909             }
5910              
5911             # $$ --> $$
5912             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5913             }
5914              
5915             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5916 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5917 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5918 0         0 $char[$i] = e_capture($1);
5919             if ($ignorecase) {
5920             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5921             }
5922 0         0 }
5923 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5924 0         0 $char[$i] = e_capture($1);
5925             if ($ignorecase) {
5926             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5927             }
5928             }
5929              
5930 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5931 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) {
5932 0         0 $char[$i] = e_capture($1.'->'.$2);
5933             if ($ignorecase) {
5934             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5935             }
5936             }
5937              
5938 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5939 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) {
5940 0         0 $char[$i] = e_capture($1.'->'.$2);
5941             if ($ignorecase) {
5942             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5943             }
5944             }
5945              
5946 0         0 # $$foo
5947 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5948 0         0 $char[$i] = e_capture($1);
5949             if ($ignorecase) {
5950             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5951             }
5952             }
5953              
5954 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
5955 8         25 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5956             if ($ignorecase) {
5957             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::PREMATCH())]}';
5958 0         0 }
5959             else {
5960             $char[$i] = '@{[Eusascii::PREMATCH()]}';
5961             }
5962             }
5963              
5964 8 50       23 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
5965 8         21 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5966             if ($ignorecase) {
5967             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::MATCH())]}';
5968 0         0 }
5969             else {
5970             $char[$i] = '@{[Eusascii::MATCH()]}';
5971             }
5972             }
5973              
5974 8 50       21 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
5975 6         15 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5976             if ($ignorecase) {
5977             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::POSTMATCH())]}';
5978 0         0 }
5979             else {
5980             $char[$i] = '@{[Eusascii::POSTMATCH()]}';
5981             }
5982             }
5983              
5984 6 0       17 # ${ foo }
5985 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) {
5986             if ($ignorecase) {
5987             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5988             }
5989             }
5990              
5991 0         0 # ${ ... }
5992 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5993 0         0 $char[$i] = e_capture($1);
5994             if ($ignorecase) {
5995             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
5996             }
5997             }
5998              
5999 0         0 # $scalar or @array
6000 5 100       14 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6001 5         13 $char[$i] = e_string($char[$i]);
6002             if ($ignorecase) {
6003             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6004             }
6005             }
6006              
6007 3 100 33     12 # quote character before ? + * {
    50          
6008             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6009             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6010 138         1044 }
6011 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6012 0         0 my $char = $char[$i-1];
6013             if ($char[$i] eq '{') {
6014             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6015 0         0 }
6016             else {
6017             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6018             }
6019 0         0 }
6020             else {
6021             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6022             }
6023             }
6024             }
6025 127         469  
6026 614 50       1144 # make regexp string
6027 614 0 0     1241 $modifier =~ tr/i//d;
6028 0         0 if ($left_e > $right_e) {
6029             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6030             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6031 0         0 }
6032             else {
6033             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6034 0 50 33     0 }
6035 614         3545 }
6036             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6037             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6038 0         0 }
6039             else {
6040             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6041             }
6042             }
6043              
6044             #
6045             # double quote stuff
6046 614     180 0 6261 #
6047             sub qq_stuff {
6048             my($delimiter,$end_delimiter,$stuff) = @_;
6049 180 100       314  
6050 180         363 # scalar variable or array variable
6051             if ($stuff =~ /\A [\$\@] /oxms) {
6052             return $stuff;
6053             }
6054 100         334  
  80         186  
6055 80         230 # quote by delimiter
6056 80 50       217 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6057 80 50       148 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6058 80 50       119 next if $char eq $delimiter;
6059 80         132 next if $char eq $end_delimiter;
6060             if (not $octet{$char}) {
6061             return join '', 'qq', $char, $stuff, $char;
6062 80         300 }
6063             }
6064             return join '', 'qq', '<', $stuff, '>';
6065             }
6066              
6067             #
6068             # escape regexp (m'', qr'', and m''b, qr''b)
6069 0     10 0 0 #
6070 10   50     60 sub e_qr_q {
6071             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6072 10         49 $modifier ||= '';
6073 10 50       13  
6074 10         22 $modifier =~ tr/p//d;
6075 0         0 if ($modifier =~ /([adlu])/oxms) {
6076 0 0       0 my $line = 0;
6077 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6078 0         0 if ($filename ne __FILE__) {
6079             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6080             last;
6081 0         0 }
6082             }
6083             die qq{Unsupported modifier "$1" used at line $line.\n};
6084 0         0 }
6085              
6086             $slash = 'div';
6087 10 100       15  
    50          
6088 10         28 # literal null string pattern
6089 8         9 if ($string eq '') {
6090 8         12 $modifier =~ tr/bB//d;
6091             $modifier =~ tr/i//d;
6092             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6093             }
6094              
6095 8         39 # with /b /B modifier
6096             elsif ($modifier =~ tr/bB//d) {
6097             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6098             }
6099              
6100 0         0 # without /b /B modifier
6101             else {
6102             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6103             }
6104             }
6105              
6106             #
6107             # escape regexp (m'', qr'')
6108 2     2 0 8 #
6109             sub e_qr_qt {
6110 2 50       6 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6111              
6112             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6113 2         6  
6114             # split regexp
6115             my @char = $string =~ /\G((?>
6116             [^\\\[\$\@\/] |
6117             [\x00-\xFF] |
6118             \[\^ |
6119             \[\: (?>[a-z]+) \:\] |
6120             \[\:\^ (?>[a-z]+) \:\] |
6121             [\$\@\/] |
6122             \\ (?:$q_char) |
6123             (?:$q_char)
6124             ))/oxmsg;
6125 2         110  
6126 2 50 33     11 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6127             for (my $i=0; $i <= $#char; $i++) {
6128             if (0) {
6129             }
6130 2         17  
6131 0         0 # open character class [...]
6132 0 0       0 elsif ($char[$i] eq '[') {
6133 0         0 my $left = $i;
6134             if ($char[$i+1] eq ']') {
6135 0         0 $i++;
6136 0 0       0 }
6137 0         0 while (1) {
6138             if (++$i > $#char) {
6139 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6140 0         0 }
6141             if ($char[$i] eq ']') {
6142             my $right = $i;
6143 0         0  
6144             # [...]
6145 0         0 splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
6146 0         0  
6147             $i = $left;
6148             last;
6149             }
6150             }
6151             }
6152              
6153 0         0 # open character class [^...]
6154 0 0       0 elsif ($char[$i] eq '[^') {
6155 0         0 my $left = $i;
6156             if ($char[$i+1] eq ']') {
6157 0         0 $i++;
6158 0 0       0 }
6159 0         0 while (1) {
6160             if (++$i > $#char) {
6161 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6162 0         0 }
6163             if ($char[$i] eq ']') {
6164             my $right = $i;
6165 0         0  
6166             # [^...]
6167 0         0 splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6168 0         0  
6169             $i = $left;
6170             last;
6171             }
6172             }
6173             }
6174              
6175 0         0 # escape $ @ / and \
6176             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6177             $char[$i] = '\\' . $char[$i];
6178             }
6179              
6180 0         0 # rewrite character class or escape character
6181             elsif (my $char = character_class($char[$i],$modifier)) {
6182             $char[$i] = $char;
6183             }
6184              
6185 0 0       0 # /i modifier
6186 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
6187             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
6188             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
6189 0         0 }
6190             else {
6191             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
6192             }
6193             }
6194              
6195 0 0       0 # quote character before ? + * {
6196             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6197             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6198 0         0 }
6199             else {
6200             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6201             }
6202             }
6203 0         0 }
6204 2         13  
6205             $delimiter = '/';
6206 2         3 $end_delimiter = '/';
6207 2         3  
6208             $modifier =~ tr/i//d;
6209             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6210             }
6211              
6212             #
6213             # escape regexp (m''b, qr''b)
6214 2     0 0 17 #
6215             sub e_qr_qb {
6216             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6217 0         0  
6218             # split regexp
6219             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6220 0         0  
6221 0 0       0 # unescape character
    0          
6222             for (my $i=0; $i <= $#char; $i++) {
6223             if (0) {
6224             }
6225 0         0  
6226             # remain \\
6227             elsif ($char[$i] eq '\\\\') {
6228             }
6229              
6230 0         0 # escape $ @ / and \
6231             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6232             $char[$i] = '\\' . $char[$i];
6233             }
6234 0         0 }
6235 0         0  
6236 0         0 $delimiter = '/';
6237             $end_delimiter = '/';
6238             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6239             }
6240              
6241             #
6242             # escape regexp (s/here//)
6243 0     76 0 0 #
6244 76   100     222 sub e_s1 {
6245             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6246 76         336 $modifier ||= '';
6247 76 50       120  
6248 76         229 $modifier =~ tr/p//d;
6249 0         0 if ($modifier =~ /([adlu])/oxms) {
6250 0 0       0 my $line = 0;
6251 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6252 0         0 if ($filename ne __FILE__) {
6253             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6254             last;
6255 0         0 }
6256             }
6257             die qq{Unsupported modifier "$1" used at line $line.\n};
6258 0         0 }
6259              
6260             $slash = 'div';
6261 76 100       155  
    50          
6262 76         458 # literal null string pattern
6263 8         13 if ($string eq '') {
6264 8         11 $modifier =~ tr/bB//d;
6265             $modifier =~ tr/i//d;
6266             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6267             }
6268              
6269             # /b /B modifier
6270             elsif ($modifier =~ tr/bB//d) {
6271 8 0       58  
6272 0         0 # choice again delimiter
6273 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6274 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6275 0         0 my %octet = map {$_ => 1} @char;
6276 0         0 if (not $octet{')'}) {
6277             $delimiter = '(';
6278             $end_delimiter = ')';
6279 0         0 }
6280 0         0 elsif (not $octet{'}'}) {
6281             $delimiter = '{';
6282             $end_delimiter = '}';
6283 0         0 }
6284 0         0 elsif (not $octet{']'}) {
6285             $delimiter = '[';
6286             $end_delimiter = ']';
6287 0         0 }
6288 0         0 elsif (not $octet{'>'}) {
6289             $delimiter = '<';
6290             $end_delimiter = '>';
6291 0         0 }
6292 0 0       0 else {
6293 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6294 0         0 if (not $octet{$char}) {
6295 0         0 $delimiter = $char;
6296             $end_delimiter = $char;
6297             last;
6298             }
6299             }
6300             }
6301 0         0 }
6302 0         0  
6303             my $prematch = '';
6304             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6305 0 100       0 }
6306 68         190  
6307             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6308             my $metachar = qr/[\@\\|[\]{^]/oxms;
6309 68         291  
6310             # split regexp
6311             my @char = $string =~ /\G((?>
6312             [^\\\$\@\[\(] |
6313             \\ (?>[1-9][0-9]*) |
6314             \\g (?>\s*) (?>[1-9][0-9]*) |
6315             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6316             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6317             \\x (?>[0-9A-Fa-f]{1,2}) |
6318             \\ (?>[0-7]{2,3}) |
6319             \\c [\x40-\x5F] |
6320             \\x\{ (?>[0-9A-Fa-f]+) \} |
6321             \\o\{ (?>[0-7]+) \} |
6322             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6323             \\ $q_char |
6324             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6325             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6326             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6327             [\$\@] $qq_variable |
6328             \$ (?>\s* [0-9]+) |
6329             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6330             \$ \$ (?![\w\{]) |
6331             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6332             \[\^ |
6333             \[\: (?>[a-z]+) :\] |
6334             \[\:\^ (?>[a-z]+) :\] |
6335             \(\? |
6336             $q_char
6337             ))/oxmsg;
6338 68 50       17227  
6339 68         480 # choice again delimiter
  0         0  
6340 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6341 0         0 my %octet = map {$_ => 1} @char;
6342 0         0 if (not $octet{')'}) {
6343             $delimiter = '(';
6344             $end_delimiter = ')';
6345 0         0 }
6346 0         0 elsif (not $octet{'}'}) {
6347             $delimiter = '{';
6348             $end_delimiter = '}';
6349 0         0 }
6350 0         0 elsif (not $octet{']'}) {
6351             $delimiter = '[';
6352             $end_delimiter = ']';
6353 0         0 }
6354 0         0 elsif (not $octet{'>'}) {
6355             $delimiter = '<';
6356             $end_delimiter = '>';
6357 0         0 }
6358 0 0       0 else {
6359 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6360 0         0 if (not $octet{$char}) {
6361 0         0 $delimiter = $char;
6362             $end_delimiter = $char;
6363             last;
6364             }
6365             }
6366             }
6367             }
6368 0         0  
  68         137  
6369             # count '('
6370 253         433 my $parens = grep { $_ eq '(' } @char;
6371 68         104  
6372 68         107 my $left_e = 0;
6373             my $right_e = 0;
6374             for (my $i=0; $i <= $#char; $i++) {
6375 68 50 33     187  
    50 33        
    100          
    100          
    50          
    50          
6376 195         1226 # "\L\u" --> "\u\L"
6377             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6378             @char[$i,$i+1] = @char[$i+1,$i];
6379             }
6380              
6381 0         0 # "\U\l" --> "\l\U"
6382             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6383             @char[$i,$i+1] = @char[$i+1,$i];
6384             }
6385              
6386 0         0 # octal escape sequence
6387             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6388             $char[$i] = Eusascii::octchr($1);
6389             }
6390              
6391 1         4 # hexadecimal escape sequence
6392             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6393             $char[$i] = Eusascii::hexchr($1);
6394             }
6395              
6396             # \b{...} --> b\{...}
6397             # \B{...} --> B\{...}
6398             # \N{CHARNAME} --> N\{CHARNAME}
6399             # \p{PROPERTY} --> p\{PROPERTY}
6400 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6401             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6402             $char[$i] = $1 . '\\' . $2;
6403             }
6404              
6405 0         0 # \p, \P, \X --> p, P, X
6406             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6407             $char[$i] = $1;
6408 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          
6409              
6410             if (0) {
6411             }
6412 195         685  
6413 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6414 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6415             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)) {
6416             $char[$i] .= join '', splice @char, $i+1, 3;
6417 0         0 }
6418             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)) {
6419             $char[$i] .= join '', splice @char, $i+1, 2;
6420 0         0 }
6421             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)) {
6422             $char[$i] .= join '', splice @char, $i+1, 1;
6423             }
6424             }
6425              
6426 0         0 # open character class [...]
6427 13 50       21 elsif ($char[$i] eq '[') {
6428 13         482 my $left = $i;
6429             if ($char[$i+1] eq ']') {
6430 0         0 $i++;
6431 13 50       20 }
6432 58         84 while (1) {
6433             if (++$i > $#char) {
6434 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6435 58         144 }
6436             if ($char[$i] eq ']') {
6437             my $right = $i;
6438 13 50       23  
6439 13         82 # [...]
  0         0  
6440             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6441             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);
6442 0         0 }
6443             else {
6444             splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
6445 13         55 }
6446 13         25  
6447             $i = $left;
6448             last;
6449             }
6450             }
6451             }
6452              
6453 13         33 # open character class [^...]
6454 0 0       0 elsif ($char[$i] eq '[^') {
6455 0         0 my $left = $i;
6456             if ($char[$i+1] eq ']') {
6457 0         0 $i++;
6458 0 0       0 }
6459 0         0 while (1) {
6460             if (++$i > $#char) {
6461 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6462 0         0 }
6463             if ($char[$i] eq ']') {
6464             my $right = $i;
6465 0 0       0  
6466 0         0 # [^...]
  0         0  
6467             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6468             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);
6469 0         0 }
6470             else {
6471             splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6472 0         0 }
6473 0         0  
6474             $i = $left;
6475             last;
6476             }
6477             }
6478             }
6479              
6480 0         0 # rewrite character class or escape character
6481             elsif (my $char = character_class($char[$i],$modifier)) {
6482             $char[$i] = $char;
6483             }
6484              
6485 7 50       15 # /i modifier
6486 3         6 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
6487             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
6488             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
6489 3         5 }
6490             else {
6491             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
6492             }
6493             }
6494              
6495 0 0       0 # \u \l \U \L \F \Q \E
6496 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6497             if ($right_e < $left_e) {
6498             $char[$i] = '\\' . $char[$i];
6499             }
6500 0         0 }
6501 0         0 elsif ($char[$i] eq '\u') {
6502             $char[$i] = '@{[Eusascii::ucfirst qq<';
6503             $left_e++;
6504 0         0 }
6505 0         0 elsif ($char[$i] eq '\l') {
6506             $char[$i] = '@{[Eusascii::lcfirst qq<';
6507             $left_e++;
6508 0         0 }
6509 0         0 elsif ($char[$i] eq '\U') {
6510             $char[$i] = '@{[Eusascii::uc qq<';
6511             $left_e++;
6512 0         0 }
6513 0         0 elsif ($char[$i] eq '\L') {
6514             $char[$i] = '@{[Eusascii::lc qq<';
6515             $left_e++;
6516 0         0 }
6517 0         0 elsif ($char[$i] eq '\F') {
6518             $char[$i] = '@{[Eusascii::fc qq<';
6519             $left_e++;
6520 0         0 }
6521 0         0 elsif ($char[$i] eq '\Q') {
6522             $char[$i] = '@{[CORE::quotemeta qq<';
6523             $left_e++;
6524 0 0       0 }
6525 0         0 elsif ($char[$i] eq '\E') {
6526 0         0 if ($right_e < $left_e) {
6527             $char[$i] = '>]}';
6528             $right_e++;
6529 0         0 }
6530             else {
6531             $char[$i] = '';
6532             }
6533 0         0 }
6534 0 0       0 elsif ($char[$i] eq '\Q') {
6535 0         0 while (1) {
6536             if (++$i > $#char) {
6537 0 0       0 last;
6538 0         0 }
6539             if ($char[$i] eq '\E') {
6540             last;
6541             }
6542             }
6543             }
6544             elsif ($char[$i] eq '\E') {
6545             }
6546              
6547             # \0 --> \0
6548             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6549             }
6550              
6551             # \g{N}, \g{-N}
6552              
6553             # P.108 Using Simple Patterns
6554             # in Chapter 7: In the World of Regular Expressions
6555             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6556              
6557             # P.221 Capturing
6558             # in Chapter 5: Pattern Matching
6559             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6560              
6561             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6562             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6563             }
6564              
6565             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6566             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6567             }
6568              
6569             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6570             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6571             }
6572              
6573             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6574             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6575             }
6576              
6577 0 0       0 # $0 --> $0
6578 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6579             if ($ignorecase) {
6580             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6581             }
6582 0 0       0 }
6583 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6584             if ($ignorecase) {
6585             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6586             }
6587             }
6588              
6589             # $$ --> $$
6590             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6591             }
6592              
6593             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6594 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6595 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6596 0         0 $char[$i] = e_capture($1);
6597             if ($ignorecase) {
6598             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6599             }
6600 0         0 }
6601 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6602 0         0 $char[$i] = e_capture($1);
6603             if ($ignorecase) {
6604             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6605             }
6606             }
6607              
6608 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6609 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) {
6610 0         0 $char[$i] = e_capture($1.'->'.$2);
6611             if ($ignorecase) {
6612             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6613             }
6614             }
6615              
6616 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6617 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) {
6618 0         0 $char[$i] = e_capture($1.'->'.$2);
6619             if ($ignorecase) {
6620             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6621             }
6622             }
6623              
6624 0         0 # $$foo
6625 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6626 0         0 $char[$i] = e_capture($1);
6627             if ($ignorecase) {
6628             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6629             }
6630             }
6631              
6632 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
6633 4         12 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6634             if ($ignorecase) {
6635             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::PREMATCH())]}';
6636 0         0 }
6637             else {
6638             $char[$i] = '@{[Eusascii::PREMATCH()]}';
6639             }
6640             }
6641              
6642 4 50       14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
6643 4         13 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6644             if ($ignorecase) {
6645             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::MATCH())]}';
6646 0         0 }
6647             else {
6648             $char[$i] = '@{[Eusascii::MATCH()]}';
6649             }
6650             }
6651              
6652 4 50       15 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
6653 3         9 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6654             if ($ignorecase) {
6655             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::POSTMATCH())]}';
6656 0         0 }
6657             else {
6658             $char[$i] = '@{[Eusascii::POSTMATCH()]}';
6659             }
6660             }
6661              
6662 3 0       11 # ${ foo }
6663 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) {
6664             if ($ignorecase) {
6665             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6666             }
6667             }
6668              
6669 0         0 # ${ ... }
6670 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6671 0         0 $char[$i] = e_capture($1);
6672             if ($ignorecase) {
6673             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6674             }
6675             }
6676              
6677 0         0 # $scalar or @array
6678 4 50       22 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6679 4         21 $char[$i] = e_string($char[$i]);
6680             if ($ignorecase) {
6681             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
6682             }
6683             }
6684              
6685 0 50       0 # quote character before ? + * {
6686             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6687             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6688 13         85 }
6689             else {
6690             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6691             }
6692             }
6693             }
6694 13         69  
6695 68         152 # make regexp string
6696 68 50       116 my $prematch = '';
6697 68         175 $modifier =~ tr/i//d;
6698             if ($left_e > $right_e) {
6699 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6700             }
6701             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6702             }
6703              
6704             #
6705             # escape regexp (s'here'' or s'here''b)
6706 68     21 0 743 #
6707 21   100     49 sub e_s1_q {
6708             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6709 21         72 $modifier ||= '';
6710 21 50       26  
6711 21         42 $modifier =~ tr/p//d;
6712 0         0 if ($modifier =~ /([adlu])/oxms) {
6713 0 0       0 my $line = 0;
6714 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6715 0         0 if ($filename ne __FILE__) {
6716             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6717             last;
6718 0         0 }
6719             }
6720             die qq{Unsupported modifier "$1" used at line $line.\n};
6721 0         0 }
6722              
6723             $slash = 'div';
6724 21 100       30  
    50          
6725 21         129 # literal null string pattern
6726 8         9 if ($string eq '') {
6727 8         9 $modifier =~ tr/bB//d;
6728             $modifier =~ tr/i//d;
6729             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6730             }
6731              
6732 8         51 # with /b /B modifier
6733             elsif ($modifier =~ tr/bB//d) {
6734             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6735             }
6736              
6737 0         0 # without /b /B modifier
6738             else {
6739             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6740             }
6741             }
6742              
6743             #
6744             # escape regexp (s'here'')
6745 13     13 0 30 #
6746             sub e_s1_qt {
6747 13 50       32 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6748              
6749             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6750 13         42  
6751             # split regexp
6752             my @char = $string =~ /\G((?>
6753             [^\\\[\$\@\/] |
6754             [\x00-\xFF] |
6755             \[\^ |
6756             \[\: (?>[a-z]+) \:\] |
6757             \[\:\^ (?>[a-z]+) \:\] |
6758             [\$\@\/] |
6759             \\ (?:$q_char) |
6760             (?:$q_char)
6761             ))/oxmsg;
6762 13         200  
6763 13 50 33     83 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6764             for (my $i=0; $i <= $#char; $i++) {
6765             if (0) {
6766             }
6767 25         140  
6768 0         0 # open character class [...]
6769 0 0       0 elsif ($char[$i] eq '[') {
6770 0         0 my $left = $i;
6771             if ($char[$i+1] eq ']') {
6772 0         0 $i++;
6773 0 0       0 }
6774 0         0 while (1) {
6775             if (++$i > $#char) {
6776 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6777 0         0 }
6778             if ($char[$i] eq ']') {
6779             my $right = $i;
6780 0         0  
6781             # [...]
6782 0         0 splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
6783 0         0  
6784             $i = $left;
6785             last;
6786             }
6787             }
6788             }
6789              
6790 0         0 # open character class [^...]
6791 0 0       0 elsif ($char[$i] eq '[^') {
6792 0         0 my $left = $i;
6793             if ($char[$i+1] eq ']') {
6794 0         0 $i++;
6795 0 0       0 }
6796 0         0 while (1) {
6797             if (++$i > $#char) {
6798 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6799 0         0 }
6800             if ($char[$i] eq ']') {
6801             my $right = $i;
6802 0         0  
6803             # [^...]
6804 0         0 splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6805 0         0  
6806             $i = $left;
6807             last;
6808             }
6809             }
6810             }
6811              
6812 0         0 # escape $ @ / and \
6813             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6814             $char[$i] = '\\' . $char[$i];
6815             }
6816              
6817 0         0 # rewrite character class or escape character
6818             elsif (my $char = character_class($char[$i],$modifier)) {
6819             $char[$i] = $char;
6820             }
6821              
6822 6 0       13 # /i modifier
6823 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
6824             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
6825             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
6826 0         0 }
6827             else {
6828             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
6829             }
6830             }
6831              
6832 0 0       0 # quote character before ? + * {
6833             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6834             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6835 0         0 }
6836             else {
6837             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6838             }
6839             }
6840 0         0 }
6841 13         67  
6842 13         25 $modifier =~ tr/i//d;
6843 13         18 $delimiter = '/';
6844 13         15 $end_delimiter = '/';
6845             my $prematch = '';
6846             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6847             }
6848              
6849             #
6850             # escape regexp (s'here''b)
6851 13     0 0 112 #
6852             sub e_s1_qb {
6853             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6854 0         0  
6855             # split regexp
6856             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6857 0         0  
6858 0 0       0 # unescape character
    0          
6859             for (my $i=0; $i <= $#char; $i++) {
6860             if (0) {
6861             }
6862 0         0  
6863             # remain \\
6864             elsif ($char[$i] eq '\\\\') {
6865             }
6866              
6867 0         0 # escape $ @ / and \
6868             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6869             $char[$i] = '\\' . $char[$i];
6870             }
6871 0         0 }
6872 0         0  
6873 0         0 $delimiter = '/';
6874 0         0 $end_delimiter = '/';
6875             my $prematch = '';
6876             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6877             }
6878              
6879             #
6880             # escape regexp (s''here')
6881 0     16 0 0 #
6882             sub e_s2_q {
6883 16         34 my($ope,$delimiter,$end_delimiter,$string) = @_;
6884              
6885 16         24 $slash = 'div';
6886 16         115  
6887 16 100       54 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
6888             for (my $i=0; $i <= $#char; $i++) {
6889             if (0) {
6890             }
6891 9         31  
6892             # not escape \\
6893             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6894             }
6895              
6896 0         0 # escape $ @ / and \
6897             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6898             $char[$i] = '\\' . $char[$i];
6899             }
6900 5         15 }
6901              
6902             return join '', $ope, $delimiter, @char, $end_delimiter;
6903             }
6904              
6905             #
6906             # escape regexp (s/here/and here/modifier)
6907 16     97 0 54 #
6908 97   100     947 sub e_sub {
6909             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6910 97         457 $modifier ||= '';
6911 97 50       198  
6912 97         268 $modifier =~ tr/p//d;
6913 0         0 if ($modifier =~ /([adlu])/oxms) {
6914 0 0       0 my $line = 0;
6915 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6916 0         0 if ($filename ne __FILE__) {
6917             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6918             last;
6919 0         0 }
6920             }
6921             die qq{Unsupported modifier "$1" used at line $line.\n};
6922 0 100       0 }
6923 97         263  
6924 36         48 if ($variable eq '') {
6925             $variable = '$_';
6926             $bind_operator = ' =~ ';
6927 36         46 }
6928              
6929             $slash = 'div';
6930              
6931             # P.128 Start of match (or end of previous match): \G
6932             # P.130 Advanced Use of \G with Perl
6933             # in Chapter 3: Overview of Regular Expression Features and Flavors
6934             # P.312 Iterative Matching: Scalar Context, with /g
6935             # in Chapter 7: Perl
6936             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6937              
6938             # P.181 Where You Left Off: The \G Assertion
6939             # in Chapter 5: Pattern Matching
6940             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6941              
6942             # P.220 Where You Left Off: The \G Assertion
6943             # in Chapter 5: Pattern Matching
6944 97         158 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6945 97         147  
6946             my $e_modifier = $modifier =~ tr/e//d;
6947 97         139 my $r_modifier = $modifier =~ tr/r//d;
6948 97 50       147  
6949 97         297 my $my = '';
6950 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6951 0         0 $my = $variable;
6952             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6953             $variable =~ s/ = .+ \z//oxms;
6954 0         0 }
6955 97         236  
6956             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6957             $variable_basename =~ s/ \s+ \z//oxms;
6958 97         184  
6959 97 100       151 # quote replacement string
6960 97         216 my $e_replacement = '';
6961 17         35 if ($e_modifier >= 1) {
6962             $e_replacement = e_qq('', '', '', $replacement);
6963             $e_modifier--;
6964 17 100       37 }
6965 80         196 else {
6966             if ($delimiter2 eq "'") {
6967             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6968 16         64 }
6969             else {
6970             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6971             }
6972 64         149 }
6973              
6974             my $sub = '';
6975 97 100       179  
6976 97 100       224 # with /r
6977             if ($r_modifier) {
6978             if (0) {
6979             }
6980 8         20  
6981 0 50       0 # s///gr without multibyte anchoring
6982             elsif ($modifier =~ /g/oxms) {
6983             $sub = sprintf(
6984             # 1 2 3 4 5
6985             q,
6986              
6987             $variable, # 1
6988             ($delimiter1 eq "'") ? # 2
6989             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6990             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6991             $s_matched, # 3
6992             $e_replacement, # 4
6993             '$Eusascii::re_r=CORE::eval $Eusascii::re_r; ' x $e_modifier, # 5
6994             );
6995             }
6996              
6997             # s///r
6998 4         14 else {
6999              
7000 4 50       4 my $prematch = q{$`};
7001              
7002             $sub = sprintf(
7003             # 1 2 3 4 5 6 7
7004             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Eusascii::re_r=%s; %s"%s$Eusascii::re_r$'" } : %s>,
7005              
7006             $variable, # 1
7007             ($delimiter1 eq "'") ? # 2
7008             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7009             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7010             $s_matched, # 3
7011             $e_replacement, # 4
7012             '$Eusascii::re_r=CORE::eval $Eusascii::re_r; ' x $e_modifier, # 5
7013             $prematch, # 6
7014             $variable, # 7
7015             );
7016             }
7017 4 50       11  
7018 8         23 # $var !~ s///r doesn't make sense
7019             if ($bind_operator =~ / !~ /oxms) {
7020             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7021             }
7022             }
7023              
7024 0 100       0 # without /r
7025             else {
7026             if (0) {
7027             }
7028 89         214  
7029 0 100       0 # s///g without multibyte anchoring
    100          
7030             elsif ($modifier =~ /g/oxms) {
7031             $sub = sprintf(
7032             # 1 2 3 4 5 6 7 8
7033             q,
7034              
7035             $variable, # 1
7036             ($delimiter1 eq "'") ? # 2
7037             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7038             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7039             $s_matched, # 3
7040             $e_replacement, # 4
7041             '$Eusascii::re_r=CORE::eval $Eusascii::re_r; ' x $e_modifier, # 5
7042             $variable, # 6
7043             $variable, # 7
7044             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7045             );
7046             }
7047              
7048             # s///
7049 22         79 else {
7050              
7051 67 100       112 my $prematch = q{$`};
    100          
7052              
7053             $sub = sprintf(
7054              
7055             ($bind_operator =~ / =~ /oxms) ?
7056              
7057             # 1 2 3 4 5 6 7 8
7058             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Eusascii::re_r=%s; %s%s="%s$Eusascii::re_r$'"; 1 } : undef> :
7059              
7060             # 1 2 3 4 5 6 7 8
7061             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Eusascii::re_r=%s; %s%s="%s$Eusascii::re_r$'"; undef }>,
7062              
7063             $variable, # 1
7064             $bind_operator, # 2
7065             ($delimiter1 eq "'") ? # 3
7066             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7067             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7068             $s_matched, # 4
7069             $e_replacement, # 5
7070             '$Eusascii::re_r=CORE::eval $Eusascii::re_r; ' x $e_modifier, # 6
7071             $variable, # 7
7072             $prematch, # 8
7073             );
7074             }
7075             }
7076 67 50       385  
7077 97         279 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7078             if ($my ne '') {
7079             $sub = "($my, $sub)[1]";
7080             }
7081 0         0  
7082 97         154 # clear s/// variable
7083             $sub_variable = '';
7084 97         141 $bind_operator = '';
7085              
7086             return $sub;
7087             }
7088              
7089             #
7090             # escape regexp of split qr//
7091 97     74 0 2900 #
7092 74   100     328 sub e_split {
7093             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7094 74         340 $modifier ||= '';
7095 74 50       125  
7096 74         167 $modifier =~ tr/p//d;
7097 0         0 if ($modifier =~ /([adlu])/oxms) {
7098 0 0       0 my $line = 0;
7099 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7100 0         0 if ($filename ne __FILE__) {
7101             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7102             last;
7103 0         0 }
7104             }
7105             die qq{Unsupported modifier "$1" used at line $line.\n};
7106 0         0 }
7107              
7108             $slash = 'div';
7109 74 50       123  
7110 74         144 # /b /B modifier
7111             if ($modifier =~ tr/bB//d) {
7112             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7113 0 50       0 }
7114 74         184  
7115             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7116             my $metachar = qr/[\@\\|[\]{^]/oxms;
7117 74         246  
7118             # split regexp
7119             my @char = $string =~ /\G((?>
7120             [^\\\$\@\[\(] |
7121             \\x (?>[0-9A-Fa-f]{1,2}) |
7122             \\ (?>[0-7]{2,3}) |
7123             \\c [\x40-\x5F] |
7124             \\x\{ (?>[0-9A-Fa-f]+) \} |
7125             \\o\{ (?>[0-7]+) \} |
7126             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7127             \\ $q_char |
7128             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7129             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7130             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7131             [\$\@] $qq_variable |
7132             \$ (?>\s* [0-9]+) |
7133             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7134             \$ \$ (?![\w\{]) |
7135             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7136             \[\^ |
7137             \[\: (?>[a-z]+) :\] |
7138             \[\:\^ (?>[a-z]+) :\] |
7139             \(\? |
7140             $q_char
7141 74         9676 ))/oxmsg;
7142 74         254  
7143 74         112 my $left_e = 0;
7144             my $right_e = 0;
7145             for (my $i=0; $i <= $#char; $i++) {
7146 74 50 33     1031  
    50 33        
    100          
    100          
    50          
    50          
7147 249         1303 # "\L\u" --> "\u\L"
7148             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7149             @char[$i,$i+1] = @char[$i+1,$i];
7150             }
7151              
7152 0         0 # "\U\l" --> "\l\U"
7153             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7154             @char[$i,$i+1] = @char[$i+1,$i];
7155             }
7156              
7157 0         0 # octal escape sequence
7158             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7159             $char[$i] = Eusascii::octchr($1);
7160             }
7161              
7162 1         3 # hexadecimal escape sequence
7163             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7164             $char[$i] = Eusascii::hexchr($1);
7165             }
7166              
7167             # \b{...} --> b\{...}
7168             # \B{...} --> B\{...}
7169             # \N{CHARNAME} --> N\{CHARNAME}
7170             # \p{PROPERTY} --> p\{PROPERTY}
7171 1         4 # \P{PROPERTY} --> P\{PROPERTY}
7172             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7173             $char[$i] = $1 . '\\' . $2;
7174             }
7175              
7176 0         0 # \p, \P, \X --> p, P, X
7177             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7178             $char[$i] = $1;
7179 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          
7180              
7181             if (0) {
7182             }
7183 249         768  
7184 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7185 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7186             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)) {
7187             $char[$i] .= join '', splice @char, $i+1, 3;
7188 0         0 }
7189             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)) {
7190             $char[$i] .= join '', splice @char, $i+1, 2;
7191 0         0 }
7192             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)) {
7193             $char[$i] .= join '', splice @char, $i+1, 1;
7194             }
7195             }
7196              
7197 0         0 # open character class [...]
7198 3 50       4 elsif ($char[$i] eq '[') {
7199 3         10 my $left = $i;
7200             if ($char[$i+1] eq ']') {
7201 0         0 $i++;
7202 3 50       6 }
7203 7         16 while (1) {
7204             if (++$i > $#char) {
7205 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7206 7         11 }
7207             if ($char[$i] eq ']') {
7208             my $right = $i;
7209 3 50       5  
7210 3         19 # [...]
  0         0  
7211             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7212             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);
7213 0         0 }
7214             else {
7215             splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
7216 3         19 }
7217 3         6  
7218             $i = $left;
7219             last;
7220             }
7221             }
7222             }
7223              
7224 3         8 # open character class [^...]
7225 0 0       0 elsif ($char[$i] eq '[^') {
7226 0         0 my $left = $i;
7227             if ($char[$i+1] eq ']') {
7228 0         0 $i++;
7229 0 0       0 }
7230 0         0 while (1) {
7231             if (++$i > $#char) {
7232 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7233 0         0 }
7234             if ($char[$i] eq ']') {
7235             my $right = $i;
7236 0 0       0  
7237 0         0 # [^...]
  0         0  
7238             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7239             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);
7240 0         0 }
7241             else {
7242             splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7243 0         0 }
7244 0         0  
7245             $i = $left;
7246             last;
7247             }
7248             }
7249             }
7250              
7251 0         0 # rewrite character class or escape character
7252             elsif (my $char = character_class($char[$i],$modifier)) {
7253             $char[$i] = $char;
7254             }
7255              
7256             # P.794 29.2.161. split
7257             # in Chapter 29: Functions
7258             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7259              
7260             # P.951 split
7261             # in Chapter 27: Functions
7262             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7263              
7264             # said "The //m modifier is assumed when you split on the pattern /^/",
7265             # but perl5.008 is not so. Therefore, this software adds //m.
7266             # (and so on)
7267              
7268 1         4 # split(m/^/) --> split(m/^/m)
7269             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7270             $modifier .= 'm';
7271             }
7272              
7273 7 0       24 # /i modifier
7274 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
7275             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
7276             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
7277 0         0 }
7278             else {
7279             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
7280             }
7281             }
7282              
7283 0 0       0 # \u \l \U \L \F \Q \E
7284 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7285             if ($right_e < $left_e) {
7286             $char[$i] = '\\' . $char[$i];
7287             }
7288 0         0 }
7289 0         0 elsif ($char[$i] eq '\u') {
7290             $char[$i] = '@{[Eusascii::ucfirst qq<';
7291             $left_e++;
7292 0         0 }
7293 0         0 elsif ($char[$i] eq '\l') {
7294             $char[$i] = '@{[Eusascii::lcfirst qq<';
7295             $left_e++;
7296 0         0 }
7297 0         0 elsif ($char[$i] eq '\U') {
7298             $char[$i] = '@{[Eusascii::uc qq<';
7299             $left_e++;
7300 0         0 }
7301 0         0 elsif ($char[$i] eq '\L') {
7302             $char[$i] = '@{[Eusascii::lc qq<';
7303             $left_e++;
7304 0         0 }
7305 0         0 elsif ($char[$i] eq '\F') {
7306             $char[$i] = '@{[Eusascii::fc qq<';
7307             $left_e++;
7308 0         0 }
7309 0         0 elsif ($char[$i] eq '\Q') {
7310             $char[$i] = '@{[CORE::quotemeta qq<';
7311             $left_e++;
7312 0 0       0 }
7313 0         0 elsif ($char[$i] eq '\E') {
7314 0         0 if ($right_e < $left_e) {
7315             $char[$i] = '>]}';
7316             $right_e++;
7317 0         0 }
7318             else {
7319             $char[$i] = '';
7320             }
7321 0         0 }
7322 0 0       0 elsif ($char[$i] eq '\Q') {
7323 0         0 while (1) {
7324             if (++$i > $#char) {
7325 0 0       0 last;
7326 0         0 }
7327             if ($char[$i] eq '\E') {
7328             last;
7329             }
7330             }
7331             }
7332             elsif ($char[$i] eq '\E') {
7333             }
7334              
7335 0 0       0 # $0 --> $0
7336 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7337             if ($ignorecase) {
7338             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7339             }
7340 0 0       0 }
7341 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7342             if ($ignorecase) {
7343             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7344             }
7345             }
7346              
7347             # $$ --> $$
7348             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7349             }
7350              
7351             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7352 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7353 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7354 0         0 $char[$i] = e_capture($1);
7355             if ($ignorecase) {
7356             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7357             }
7358 0         0 }
7359 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7360 0         0 $char[$i] = e_capture($1);
7361             if ($ignorecase) {
7362             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7363             }
7364             }
7365              
7366 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7367 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) {
7368 0         0 $char[$i] = e_capture($1.'->'.$2);
7369             if ($ignorecase) {
7370             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7371             }
7372             }
7373              
7374 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7375 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) {
7376 0         0 $char[$i] = e_capture($1.'->'.$2);
7377             if ($ignorecase) {
7378             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7379             }
7380             }
7381              
7382 0         0 # $$foo
7383 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7384 0         0 $char[$i] = e_capture($1);
7385             if ($ignorecase) {
7386             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7387             }
7388             }
7389              
7390 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Eusascii::PREMATCH()
7391 12         34 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7392             if ($ignorecase) {
7393             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::PREMATCH())]}';
7394 0         0 }
7395             else {
7396             $char[$i] = '@{[Eusascii::PREMATCH()]}';
7397             }
7398             }
7399              
7400 12 50       56 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Eusascii::MATCH()
7401 12         45 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7402             if ($ignorecase) {
7403             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::MATCH())]}';
7404 0         0 }
7405             else {
7406             $char[$i] = '@{[Eusascii::MATCH()]}';
7407             }
7408             }
7409              
7410 12 50       55 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Eusascii::POSTMATCH()
7411 9         26 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7412             if ($ignorecase) {
7413             $char[$i] = '@{[Eusascii::ignorecase(Eusascii::POSTMATCH())]}';
7414 0         0 }
7415             else {
7416             $char[$i] = '@{[Eusascii::POSTMATCH()]}';
7417             }
7418             }
7419              
7420 9 0       39 # ${ foo }
7421 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) {
7422             if ($ignorecase) {
7423             $char[$i] = '@{[Eusascii::ignorecase(' . $1 . ')]}';
7424             }
7425             }
7426              
7427 0         0 # ${ ... }
7428 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7429 0         0 $char[$i] = e_capture($1);
7430             if ($ignorecase) {
7431             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7432             }
7433             }
7434              
7435 0         0 # $scalar or @array
7436 3 50       11 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7437 3         15 $char[$i] = e_string($char[$i]);
7438             if ($ignorecase) {
7439             $char[$i] = '@{[Eusascii::ignorecase(' . $char[$i] . ')]}';
7440             }
7441             }
7442              
7443 0 50       0 # quote character before ? + * {
7444             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7445             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7446 1         7 }
7447             else {
7448             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7449             }
7450             }
7451             }
7452 0         0  
7453 74 50       145 # make regexp string
7454 74         173 $modifier =~ tr/i//d;
7455             if ($left_e > $right_e) {
7456 0         0 return join '', 'Eusascii::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7457             }
7458             return join '', 'Eusascii::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7459             }
7460              
7461             #
7462             # escape regexp of split qr''
7463 74     0 0 713 #
7464 0   0       sub e_split_q {
7465             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7466 0           $modifier ||= '';
7467 0 0          
7468 0           $modifier =~ tr/p//d;
7469 0           if ($modifier =~ /([adlu])/oxms) {
7470 0 0         my $line = 0;
7471 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7472 0           if ($filename ne __FILE__) {
7473             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7474             last;
7475 0           }
7476             }
7477             die qq{Unsupported modifier "$1" used at line $line.\n};
7478 0           }
7479              
7480             $slash = 'div';
7481 0 0          
7482 0           # /b /B modifier
7483             if ($modifier =~ tr/bB//d) {
7484             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7485 0 0         }
7486              
7487             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7488 0            
7489             # split regexp
7490             my @char = $string =~ /\G((?>
7491             [^\\\[] |
7492             [\x00-\xFF] |
7493             \[\^ |
7494             \[\: (?>[a-z]+) \:\] |
7495             \[\:\^ (?>[a-z]+) \:\] |
7496             \\ (?:$q_char) |
7497             (?:$q_char)
7498             ))/oxmsg;
7499 0            
7500 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7501             for (my $i=0; $i <= $#char; $i++) {
7502             if (0) {
7503             }
7504 0            
7505 0           # open character class [...]
7506 0 0         elsif ($char[$i] eq '[') {
7507 0           my $left = $i;
7508             if ($char[$i+1] eq ']') {
7509 0           $i++;
7510 0 0         }
7511 0           while (1) {
7512             if (++$i > $#char) {
7513 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7514 0           }
7515             if ($char[$i] eq ']') {
7516             my $right = $i;
7517 0            
7518             # [...]
7519 0           splice @char, $left, $right-$left+1, Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
7520 0            
7521             $i = $left;
7522             last;
7523             }
7524             }
7525             }
7526              
7527 0           # open character class [^...]
7528 0 0         elsif ($char[$i] eq '[^') {
7529 0           my $left = $i;
7530             if ($char[$i+1] eq ']') {
7531 0           $i++;
7532 0 0         }
7533 0           while (1) {
7534             if (++$i > $#char) {
7535 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7536 0           }
7537             if ($char[$i] eq ']') {
7538             my $right = $i;
7539 0            
7540             # [^...]
7541 0           splice @char, $left, $right-$left+1, Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7542 0            
7543             $i = $left;
7544             last;
7545             }
7546             }
7547             }
7548              
7549 0           # rewrite character class or escape character
7550             elsif (my $char = character_class($char[$i],$modifier)) {
7551             $char[$i] = $char;
7552             }
7553              
7554 0           # split(m/^/) --> split(m/^/m)
7555             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7556             $modifier .= 'm';
7557             }
7558              
7559 0 0         # /i modifier
7560 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Eusascii::uc($char[$i]) ne Eusascii::fc($char[$i]))) {
7561             if (CORE::length(Eusascii::fc($char[$i])) == 1) {
7562             $char[$i] = '[' . Eusascii::uc($char[$i]) . Eusascii::fc($char[$i]) . ']';
7563 0           }
7564             else {
7565             $char[$i] = '(?:' . Eusascii::uc($char[$i]) . '|' . Eusascii::fc($char[$i]) . ')';
7566             }
7567             }
7568              
7569 0 0         # quote character before ? + * {
7570             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7571             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7572 0           }
7573             else {
7574             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7575             }
7576             }
7577 0           }
7578 0            
7579             $modifier =~ tr/i//d;
7580             return join '', 'Eusascii::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7581             }
7582              
7583             #
7584             # instead of Carp::carp
7585 0     0 0   #
7586 0           sub carp {
7587             my($package,$filename,$line) = caller(1);
7588             print STDERR "@_ at $filename line $line.\n";
7589             }
7590              
7591             #
7592             # instead of Carp::croak
7593 0     0 0   #
7594 0           sub croak {
7595 0           my($package,$filename,$line) = caller(1);
7596             print STDERR "@_ at $filename line $line.\n";
7597             die "\n";
7598             }
7599              
7600             #
7601             # instead of Carp::cluck
7602 0     0 0   #
7603 0           sub cluck {
7604 0           my $i = 0;
7605 0           my @cluck = ();
7606 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7607             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7608 0           $i++;
7609 0           }
7610 0           print STDERR CORE::reverse @cluck;
7611             print STDERR "\n";
7612             print STDERR @_;
7613             }
7614              
7615             #
7616             # instead of Carp::confess
7617 0     0 0   #
7618 0           sub confess {
7619 0           my $i = 0;
7620 0           my @confess = ();
7621 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7622             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7623 0           $i++;
7624 0           }
7625 0           print STDERR CORE::reverse @confess;
7626 0           print STDERR "\n";
7627             print STDERR @_;
7628             die "\n";
7629             }
7630              
7631             1;
7632              
7633             __END__