File Coverage

Char/USASCII.pm
Criterion Covered Total %
statement 49 2198 2.2
branch 11 2166 0.5
condition 1 199 0.5
subroutine 14 40 35.0
pod 0 25 0.0
total 75 4628 1.6


line stmt bran cond sub pod time code
1             #
2             # This file is *** FOR CPAN USE ONLY ***.
3             #
4             # If you are an application programmer, please use file that 'Char::' removed.
5             #
6             package Char::USASCII;
7             ######################################################################
8             #
9             # Char::USASCII - Source code filter to escape US-ASCII script
10             #
11             # http://search.cpan.org/dist/Char-USASCII/
12             #
13             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014 INABA Hitoshi
14             ######################################################################
15              
16 177     177   463131 use 5.00503; # Galapagos Consensus 1998 for primetools
  177         623  
  177         12744  
17             # use 5.008001; # Lancaster Consensus 2013 for toolchains
18              
19             # 12.3. Delaying use Until Runtime
20             # in Chapter 12. Packages, Libraries, and Modules
21             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
22             # (and so on)
23              
24 177     177   12173 BEGIN { eval q{ use vars qw($VERSION) } }
  177     177   1182  
  177         349  
  177         58166  
25             $VERSION = sprintf '%d.%02d', q$Revision: 1.00 $ =~ /(\d+)/oxmsg;
26              
27             BEGIN {
28 177 50   177   1351 if ($^X =~ / jperl /oxmsi) {
29 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)";
30             }
31 177         324 if (CORE::ord('A') == 193) {
32             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).";
33             }
34 177         4570 if (CORE::ord('A') != 0x41) {
35             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).";
36             }
37             }
38              
39 177     177   304169 BEGIN { CORE::require Char::Eusascii; }
40              
41             # instead of Symbol.pm
42             BEGIN {
43 177     177   445 my $genpkg = "Symbol::";
44 177         7951 my $genseq = 0;
45             sub gensym () {
46 177     177 0 840 my $name = "GEN" . $genseq++;
47              
48             # here, no strict qw(refs); if strict.pm exists
49              
50 177         379 my $ref = \*{$genpkg . $name};
  177         2606  
51 177         1181 delete $$genpkg{$name};
52 177         648 $ref;
53             }
54             }
55              
56             # Column: local $@
57             # in Chapter 9. Osaete okitai Perl no kiso
58             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
59             # (and so on)
60              
61             # use strict; if strict.pm exists
62             BEGIN {
63 177 50   177   12488 if (eval { local $@; CORE::require strict }) {
  177         496  
  177         3347  
64 177         45626 strict::->import;
65             }
66             }
67              
68             # P.714 29.2.39. flock
69             # in Chapter 29: Functions
70             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
71              
72             # P.863 flock
73             # in Chapter 27: Functions
74             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
75              
76             # P.228 Inlining Constant Functions
77             # in Chapter 6: Subroutines
78             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
79              
80             # P.331 Inlining Constant Functions
81             # in Chapter 7: Subroutines
82             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
83              
84             sub LOCK_SH() {1}
85             sub LOCK_EX() {2}
86             sub LOCK_UN() {8}
87             sub LOCK_NB() {4}
88              
89 0     0   0 sub unimport {}
90             sub Char::USASCII::escape_script;
91              
92             # 6.18. Matching Multiple-Byte Characters
93             # in Chapter 6. Pattern Matching
94             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
95             # (and so on)
96              
97             # regexp of character
98             my $your_char = q{[\x00-\xFF]};
99             my $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
100             my $q_char = qr/$your_char/oxms;
101              
102             # P.1023 Appendix W.9 Multibyte Anchoring
103             # of ISBN 1-56592-224-7 CJKV Information Processing
104              
105             my $anchor = '';
106              
107 177     177   13440 BEGIN { eval q{ use vars qw($nest) } }
  177     177   1353  
  177         318  
  177         283148  
108              
109             # regexp of nested parens in qqXX
110              
111             # P.340 Matching Nested Constructs with Embedded Code
112             # in Chapter 7: Perl
113             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
114              
115             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
116             \\c[\x40-\x5F] |
117             \\ [\x00-\xFF] |
118             [^()] |
119             \( (?{$nest++}) |
120             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
121             }xms;
122             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
123             \\c[\x40-\x5F] |
124             \\ [\x00-\xFF] |
125             [^{}] |
126             \{ (?{$nest++}) |
127             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
128             }xms;
129             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
130             \\c[\x40-\x5F] |
131             \\ [\x00-\xFF] |
132             [^[\]] |
133             \[ (?{$nest++}) |
134             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
135             }xms;
136             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
137             \\c[\x40-\x5F] |
138             \\ [\x00-\xFF] |
139             [^<>] |
140             \< (?{$nest++}) |
141             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
142             }xms;
143             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
144             (?: ::)? (?:
145             [a-zA-Z_][a-zA-Z_0-9]*
146             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
147             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
148             ))
149             }xms;
150             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
151             (?: ::)? (?:
152             [0-9]+ |
153             [^a-zA-Z_0-9\[\]] |
154             ^[A-Z] |
155             [a-zA-Z_][a-zA-Z_0-9]*
156             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
157             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
158             ))
159             }xms;
160             my $qq_substr = qr{(?: Char::USASCII::substr | CORE::substr | substr ) \( $qq_paren \)
161             }xms;
162              
163             # regexp of nested parens in qXX
164             my $q_paren = qr{(?{local $nest=0}) (?>(?:
165             [^()] |
166             \( (?{$nest++}) |
167             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
168             }xms;
169             my $q_brace = qr{(?{local $nest=0}) (?>(?:
170             [^{}] |
171             \{ (?{$nest++}) |
172             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
173             }xms;
174             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
175             [^[\]] |
176             \[ (?{$nest++}) |
177             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
178             }xms;
179             my $q_angle = qr{(?{local $nest=0}) (?>(?:
180             [^<>] |
181             \< (?{$nest++}) |
182             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
183             }xms;
184              
185             my $matched = '';
186             my $s_matched = '';
187              
188             my $tr_variable = ''; # variable of tr///
189             my $sub_variable = ''; # variable of s///
190             my $bind_operator = ''; # =~ or !~
191 177     177   12719 BEGIN { eval q{ use vars qw($slash) } }
  177     177   1400  
  177         387  
  177         12785708  
192             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
193             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
194             my @heredoc = (); # here document
195             my @heredoc_delimiter = ();
196             my $here_script = ''; # here script
197             my $function_ord; # ord() to ord() or Char::USASCII::ord()
198             my $function_ord_; # ord to ord or Char::USASCII::ord_
199             my $function_reverse; # reverse to reverse or Char::USASCII::reverse
200             my $function_getc; # getc to getc or Char::USASCII::getc
201              
202             my $ignore_modules = join('|', qw(
203             utf8
204             bytes
205             charnames
206             I18N::Japanese
207             I18N::Collate
208             I18N::JExt
209             File::DosGlob
210             Wild
211             Wildcard
212             Japanese
213             ));
214              
215             # when this script is main program
216             if ($0 eq __FILE__) {
217              
218             # show usage
219             unless (@ARGV) {
220             die <
221             $0: usage
222              
223             perl $0 US-ASCII_script.pl > Escaped_script.pl.e
224             END
225             }
226              
227             print Char::USASCII::escape_script($ARGV[0]);
228             exit 0;
229             }
230              
231             my($package,$filename,$line,$subroutine,$hasargs,$wantarray,$evaltext,$is_require,$hints,$bitmask) = caller 0;
232              
233             # called any package not main
234             if ($package ne 'main') {
235             die <
236             @{[__FILE__]}: escape by manually command '$^X @{[__FILE__]} "$filename" > "@{[__PACKAGE__]}::$filename"'
237             and rewrite "use $package;" to "use @{[__PACKAGE__]}::$package;" of script "$0".
238             END
239             }
240              
241             # P.302 Module Privacy and the Exporter
242             # in Chapter 11: Modules
243             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
244             #
245             # A module can do anything it jolly well pleases when it's used, since use just
246             # calls the ordinary import method for the module, and you can define that
247             # method to do anything you like.
248              
249             # P.406 Module Privacy and the Exporter
250             # in Chapter 11: Modules
251             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
252             #
253             # A module can do anything it jolly well pleases when it's used, since use just
254             # calls the ordinary import method for the module, and you can define that
255             # method to do anything you like.
256              
257             sub import {
258              
259 177 50   177   10438 if (-e("$filename.e")) {
260 177 50       3747 if (exists $ENV{'SJIS_DEBUG'}) {
    50          
261 0         0 unlink "$filename.e";
262             }
263             elsif (-z("$filename.e")) {
264 0         0 unlink "$filename.e";
265             }
266             else {
267              
268             #----------------------------------------------------
269             # older >
270             # newer >>>>>
271             #----------------------------------------------------
272             # Filter >
273             # Source >>>>>
274             # Escape >>> needs re-escape (Source was changed)
275             #
276             # Filter >>>
277             # Source >>>>>
278             # Escape > needs re-escape (Source was changed)
279             #
280             # Filter >>>>>
281             # Source >>>
282             # Escape > needs re-escape (Source was changed)
283             #
284             # Filter >>>>>
285             # Source >
286             # Escape >>> needs re-escape (Filter was changed)
287             #
288             # Filter >
289             # Source >>>
290             # Escape >>>>> executable without re-escape
291             #
292             # Filter >>>
293             # Source >
294             # Escape >>>>> executable without re-escape
295             #----------------------------------------------------
296              
297 177         4583 my $mtime_filter = (stat(__FILE__ ))[9];
298 177         3178 my $mtime_source = (stat($filename ))[9];
299 177         2717 my $mtime_escape = (stat("$filename.e"))[9];
300 177 50 33     2686 if (($mtime_escape < $mtime_source) or ($mtime_escape < $mtime_filter)) {
301 0         0 unlink "$filename.e";
302             }
303             }
304             }
305              
306 177 50       3212 if (not -e("$filename.e")) {
307 0         0 my $fh = gensym();
308              
309 0 0 0     0 if (eval q{ use Fcntl qw(O_WRONLY O_APPEND O_CREAT); 1 } and CORE::sysopen($fh,"$filename.e",&O_WRONLY|&O_APPEND|&O_CREAT)) {
310             }
311             else {
312 0 0       0 Char::Eusascii::_open_a($fh, "$filename.e") or die __FILE__, ": Can't write open file: $filename.e";
313             }
314              
315 0 0       0 if (0) {
316             }
317 0         0 elsif (exists $ENV{'SJIS_NONBLOCK'}) {
318              
319             # P.419 File Locking
320             # in Chapter 16: Interprocess Communication
321             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
322              
323             # P.524 File Locking
324             # in Chapter 15: Interprocess Communication
325             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
326              
327             # P.571 Handling Race Conditions
328             # in Chapter 23: Security
329             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
330              
331             # P.663 Handling Race Conditions
332             # in Chapter 20: Security
333             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
334              
335             # (and so on)
336              
337 0         0 eval q{
338             unless (flock($fh, LOCK_EX | LOCK_NB)) {
339             warn __FILE__, ": Can't immediately write-lock the file: $filename.e";
340             exit;
341             }
342             };
343             }
344             else {
345 0         0 eval q{ flock($fh, LOCK_EX) };
346             }
347              
348 0         0 eval q{ truncate($fh, 0) };
349 0 0       0 seek($fh, 0, 0) or die __FILE__, ": Can't seek file: $filename.e";
350              
351 0         0 my $e_script = Char::USASCII::escape_script($filename);
352 0         0 print {$fh} $e_script;
  0         0  
353              
354 0         0 my $mode = (stat($filename))[2] & 0777;
355 0         0 chmod $mode, "$filename.e";
356              
357 0 0       0 close($fh) or die __FILE__, ": Can't close file: $filename.e";
358             }
359              
360 177         1461 my $fh = gensym();
361 177 50       1522 Char::Eusascii::_open_r($fh, "$filename.e") or die __FILE__, ": Can't read open file: $filename.e";
362              
363 177 50       1306 if (0) {
364             }
365 0         0 elsif (exists $ENV{'SJIS_NONBLOCK'}) {
366 0         0 eval q{
367             unless (flock($fh, LOCK_SH | LOCK_NB)) {
368             warn __FILE__, ": Can't immediately read-lock the file: $filename.e";
369             exit;
370             }
371             };
372             }
373             else {
374 177         9544 eval q{ flock($fh, LOCK_SH) };
375             }
376              
377 177         673 my @switch = ();
378 177 50       1062 if ($^W) {
379 0         0 push @switch, '-w';
380             }
381              
382             # P.707 29.2.33. exec
383             # in Chapter 29: Functions
384             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
385             #
386             # If there is more than one argument in LIST, or if LIST is an array with more
387             # than one value, the system shell will never be used. This also bypasses any
388             # shell processing of the command. The presence or absence of metacharacters in
389             # the arguments doesn't affect this list-triggered behavior, which makes it the
390             # preferred from in security-conscious programs that do not with to expose
391             # themselves to potential shell escapes.
392             # Environment variable PERL5SHELL(Microsoft ports only) will never be used, too.
393              
394             # P.855 exec
395             # in Chapter 27: Functions
396             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
397             #
398             # If there is more than one argument in LIST, or if LIST is an array with more
399             # than one value, the system shell will never be used. This also bypasses any
400             # shell processing of the command. The presence or absence of metacharacters in
401             # the arguments doesn't affect this list-triggered behavior, which makes it the
402             # preferred from in security-conscious programs that do not wish to expose
403             # themselves to injection attacks via shell escapes.
404             # Environment variable PERL5SHELL(Microsoft ports only) will never be used, too.
405              
406             # P.489 #! and Quoting on Non-Unix Systems
407             # in Chapter 19: The Command-Line Interface
408             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
409              
410             # P.578 #! and Quoting on Non-Unix Systems
411             # in Chapter 17: The Command-Line Interface
412             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
413              
414             # DOS-like system
415 177 50       1902 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
416 0         0 exit Char::Eusascii::_systemx(
417             _escapeshellcmd_MSWin32($^X),
418              
419             # -I switch can not treat space included path
420             # (map { '-I' . _escapeshellcmd_MSWin32($_) } @INC),
421 0         0 (map { '-I' . $_ } @INC),
422              
423             @switch,
424             '--',
425 0         0 map { _escapeshellcmd_MSWin32($_) } "$filename.e", @ARGV
426             );
427             }
428              
429             # UNIX-like system
430             else {
431 1947         3399 exit Char::Eusascii::_systemx(
432             _escapeshellcmd($^X),
433 177         578 (map { '-I' . _escapeshellcmd($_) } @INC),
434             @switch,
435             '--',
436 177         1208 map { _escapeshellcmd($_) } "$filename.e", @ARGV
437             );
438             }
439             }
440              
441             # escape shell command line on DOS-like system
442             sub _escapeshellcmd_MSWin32 {
443 0     0   0 my($word) = @_;
444 0 0       0 if ($word =~ / [ ] /oxms) {
445              
446             # both DOS-like and UNIX-like shell quote
447 0         0 return qq{"$word"};
448             }
449             else {
450 0         0 return $word;
451             }
452             }
453              
454             # escape shell command line on UNIX-like system
455             sub _escapeshellcmd {
456 2301     2301   3455 my($word) = @_;
457 2301         7689 return $word;
458             }
459              
460             # P.619 Source Filters
461             # in Chapter 24: Common Practices
462             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
463              
464             # P.718 Source Filters
465             # in Chapter 21: Common Practices
466             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
467              
468             # escape US-ASCII script
469             sub Char::USASCII::escape_script {
470 0     0 0   my($script) = @_;
471 0           my $e_script = '';
472              
473             # read US-ASCII script
474 0           my $fh = gensym();
475 0 0         Char::Eusascii::_open_r($fh, $script) or die __FILE__, ": Can't open file: $script";
476 0           local $/ = undef; # slurp mode
477 0           $_ = <$fh>;
478 0 0         close($fh) or die __FILE__, ": Can't close file: $script";
479              
480 0 0         if (/^ use Char::Eusascii(?:\s+[0-9\.]*)?\s*; $/oxms) {
481 0           return $_;
482             }
483             else {
484              
485             # #! shebang line
486 0 0         if (s/\A(#!.+?\n)//oms) {
487 0           my $head = $1;
488 0           $head =~ s/\bjperl\b/perl/gi;
489 0           $e_script .= $head;
490             }
491              
492             # DOS-like system header
493 0 0         if (s/\A(\@rem\s*=\s*'.*?'\s*;\s*\n)//oms) {
494 0           my $head = $1;
495 0           $head =~ s/\bjperl\b/perl/gi;
496 0           $e_script .= $head;
497             }
498              
499             # P.618 Generating Perl in Other Languages
500             # in Chapter 24: Common Practices
501             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
502              
503             # P.717 Generating Perl in Other Languages
504             # in Chapter 21: Common Practices
505             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
506              
507 0 0         if (s/(.*^#\s*line\s+\d+(?:\s+"(?:$q_char)+?")?\s*\n)//oms) {
508 0           my $head = $1;
509 0           $head =~ s/\bjperl\b/perl/gi;
510 0           $e_script .= $head;
511             }
512              
513             # P.210 5.10.3.3. Match-time code evaluation
514             # in Chapter 5: Pattern Matching
515             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
516              
517             # P.255 Match-time code evaluation
518             # in Chapter 5: Pattern Matching
519             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
520              
521 0           $e_script .= sprintf("use Char::Eusascii %s.0;\n", $Char::USASCII::VERSION); # require run-time routines version
522              
523             # use Char::USASCII version qw(ord reverse getc);
524 0           $function_ord = 'ord';
525 0           $function_ord_ = 'ord';
526 0           $function_reverse = 'reverse';
527 0           $function_getc = 'getc';
528 0 0         if (s/^ \s* use \s+ Char::USASCII \s* ([^;]*) ; \s* \n? $//oxms) {
529              
530             # require version
531 0           my $list = $1;
532 0 0         if ($list =~ s/\A ([0-9]+\.[0-9]+) \.0 \s* //oxms) {
    0          
533 0           my $version = $1;
534 0 0         if ($version ne $Char::USASCII::VERSION) {
535 0           my @file = grep -e, map {qq{$_/Char/USASCII.pm}} @INC;
  0            
536 0           my %file = map { $_ => 1 } @file;
  0            
537 0 0         if (scalar(keys %file) >= 2) {
538 0           my $file = join "\n", sort keys %file;
539 0           warn <
540             ****************************************************
541             C A U T I O N
542              
543             CONFLICT Char/USASCII.pm FILE
544              
545             $file
546             ****************************************************
547              
548             END
549             }
550 0           die "Script $0 expects Char/USASCII.pm $version, but @{[__FILE__]} is version $Char::USASCII::VERSION\n";
  0            
551             }
552 0           $e_script .= qq{die "Script \$0 expects Char/Eusascii.pm $version, but \\\$Char::Eusascii::VERSION is \$Char::Eusascii::VERSION" if \$Char::Eusascii::VERSION ne '$version';\n};
553             }
554             elsif ($list =~ s/\A ([0-9]+(?:\.[0-9]*)) \s* //oxms) {
555 0           my $version = $1;
556 0 0         if ($version > $Char::USASCII::VERSION) {
557 0           die "Script $0 required Char/USASCII.pm $version, but @{[__FILE__]} is only version $Char::USASCII::VERSION\n";
  0            
558             }
559             }
560              
561             # demand ord, reverse, and getc
562 0 0         if ($list !~ /\A \s* \z/oxms) {
563 0           local $@;
564 0           my @list = eval $list;
565 0           for (@list) {
566 0 0         $function_ord = 'Char::USASCII::ord' if /\A ord \z/oxms;
567 0 0         $function_ord_ = 'Char::USASCII::ord_' if /\A ord \z/oxms;
568 0 0         $function_reverse = 'Char::USASCII::reverse' if /\A reverse \z/oxms;
569 0 0         $function_getc = 'Char::USASCII::getc' if /\A getc \z/oxms;
570             }
571             }
572             }
573             }
574              
575 0           $slash = 'm//';
576              
577             # P.359 The Study Function
578             # in Chapter 7: Perl
579             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
580              
581 0           study $_; # Yes, I studied study yesterday.
582              
583             # while all script
584              
585             # 6.14. Matching from Where the Last Pattern Left Off
586             # in Chapter 6. Pattern Matching
587             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
588             # (and so on)
589              
590             # one member of Tag-team
591             #
592             # P.128 Start of match (or end of previous match): \G
593             # P.130 Advanced Use of \G with Perl
594             # in Chapter 3: Overview of Regular Expression Features and Flavors
595             # P.255 Use leading anchors
596             # P.256 Expose ^ and \G at the front expressions
597             # in Chapter 6: Crafting an Efficient Expression
598             # P.315 "Tag-team" matching with /gc
599             # in Chapter 7: Perl
600             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
601              
602 0           while (not /\G \z/oxgc) { # member
603 0           $e_script .= escape();
604             }
605              
606 0           return $e_script;
607             }
608              
609             # escape US-ASCII part of script
610             sub escape {
611              
612             # \n output here document
613              
614             # another member of Tag-team
615             #
616             # P.315 "Tag-team" matching with /gc
617             # in Chapter 7: Perl
618             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
619              
620 0 0 0 0 0   if (/\G ( \n ) /oxgc) { # another member (and so on)
    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          
    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          
621 0           my $heredoc = '';
622 0 0         if (scalar(@heredoc_delimiter) >= 1) {
623 0           $slash = 'm//';
624              
625 0           $heredoc = join '', @heredoc;
626 0           @heredoc = ();
627              
628             # skip here document
629 0           for my $heredoc_delimiter (@heredoc_delimiter) {
630 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
631             }
632 0           @heredoc_delimiter = ();
633              
634 0           $here_script = '';
635             }
636 0           return "\n" . $heredoc;
637             }
638              
639             # ignore space, comment
640 0           elsif (/\G (\s+|\#.*) /oxgc) { return $1; }
641              
642             # if (, elsif (, unless (, while (, until (, given (, and when (
643              
644             # given, when
645              
646             # P.225 The given Statement
647             # in Chapter 15: Smart Matching and given-when
648             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
649              
650             # P.133 The given Statement
651             # in Chapter 4: Statements and Declarations
652             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
653              
654             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) \s* \( ) /oxgc) {
655 0           $slash = 'm//';
656 0           return $1;
657             }
658              
659             # scalar variable ($scalar = ...) =~ tr///;
660             # scalar variable ($scalar = ...) =~ s///;
661              
662             # state
663              
664             # P.68 Persistent, Private Variables
665             # in Chapter 4: Subroutines
666             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
667              
668             # P.160 Persistent Lexically Scoped Variables: state
669             # in Chapter 4: Statements and Declarations
670             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
671              
672             # (and so on)
673              
674             elsif (/\G ( \( \s* (?: local \b | my \b | our \b | state \b )? \s* \$ $qq_scalar ) /oxgc) {
675 0           my $e_string = e_string($1);
676              
677 0 0         if (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
678 0           $tr_variable = $e_string . e_string($1);
679 0           $bind_operator = $2;
680 0           $slash = 'm//';
681 0           return '';
682             }
683             elsif (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
684 0           $sub_variable = $e_string . e_string($1);
685 0           $bind_operator = $2;
686 0           $slash = 'm//';
687 0           return '';
688             }
689             else {
690 0           $slash = 'div';
691 0           return $e_string;
692             }
693             }
694              
695             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
696             elsif (/\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
697 0           $slash = 'div';
698 0           return q{Char::Eusascii::PREMATCH()};
699             }
700              
701             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
702             elsif (/\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
703 0           $slash = 'div';
704 0           return q{Char::Eusascii::MATCH()};
705             }
706              
707             # $', ${'} --> $', ${'}
708             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
709 0           $slash = 'div';
710 0           return $1;
711             }
712              
713             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
714             elsif (/\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
715 0           $slash = 'div';
716 0           return q{Char::Eusascii::POSTMATCH()};
717             }
718              
719             # scalar variable $scalar =~ tr///;
720             # scalar variable $scalar =~ s///;
721             # substr() =~ tr///;
722             # substr() =~ s///;
723             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
724 0           my $scalar = e_string($1);
725              
726 0 0         if (/\G ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
727 0           $tr_variable = $scalar;
728 0           $bind_operator = $1;
729 0           $slash = 'm//';
730 0           return '';
731             }
732             elsif (/\G ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
733 0           $sub_variable = $scalar;
734 0           $bind_operator = $1;
735 0           $slash = 'm//';
736 0           return '';
737             }
738             else {
739 0           $slash = 'div';
740 0           return $scalar;
741             }
742             }
743              
744             # end of statement
745             elsif (/\G ( [,;] ) /oxgc) {
746 0           $slash = 'm//';
747              
748             # clear tr/// variable
749 0           $tr_variable = '';
750              
751             # clear s/// variable
752 0           $sub_variable = '';
753              
754 0           $bind_operator = '';
755              
756 0           return $1;
757             }
758              
759             # bareword
760             elsif (/\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
761 0           return $1;
762             }
763              
764             # $0 --> $0
765             elsif (/\G ( \$ 0 ) /oxmsgc) {
766 0           $slash = 'div';
767 0           return $1;
768             }
769             elsif (/\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
770 0           $slash = 'div';
771 0           return $1;
772             }
773              
774             # $$ --> $$
775             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
776 0           $slash = 'div';
777 0           return $1;
778             }
779              
780             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
781             # $1, $2, $3 --> $1, $2, $3 otherwise
782             elsif (/\G \$ ([1-9][0-9]*) /oxmsgc) {
783 0           $slash = 'div';
784 0           return e_capture($1);
785             }
786             elsif (/\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
787 0           $slash = 'div';
788 0           return e_capture($1);
789             }
790              
791             # $$foo[ ... ] --> $ $foo->[ ... ]
792             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
793 0           $slash = 'div';
794 0           return e_capture($1.'->'.$2);
795             }
796              
797             # $$foo{ ... } --> $ $foo->{ ... }
798             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
799 0           $slash = 'div';
800 0           return e_capture($1.'->'.$2);
801             }
802              
803             # $$foo
804             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
805 0           $slash = 'div';
806 0           return e_capture($1);
807             }
808              
809             # ${ foo }
810             elsif (/\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
811 0           $slash = 'div';
812 0           return '${' . $1 . '}';
813             }
814              
815             # ${ ... }
816             elsif (/\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
817 0           $slash = 'div';
818 0           return e_capture($1);
819             }
820              
821             # variable or function
822             # $ @ % & * $ #
823             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) {
824 0           $slash = 'div';
825 0           return $1;
826             }
827             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
828             # $ @ # \ ' " / ? ( ) [ ] < >
829             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
830 0           $slash = 'div';
831 0           return $1;
832             }
833              
834             # while ()
835             elsif (/\G \b (while \s* \( \s* <[\$]?[A-Za-z_][A-Za-z_0-9]*> \s* \)) \b /oxgc) {
836 0           return $1;
837             }
838              
839             # while () --- glob
840              
841             # avoid "Error: Runtime exception" of perl version 5.005_03
842              
843             elsif (/\G \b while \s* \( \s* < ((?:[^>\0\a\e\f\n\r\t])+?) > \s* \) \b /oxgc) {
844 0           return 'while ($_ = Char::Eusascii::glob("' . $1 . '"))';
845             }
846              
847             # while (glob)
848             elsif (/\G \b while \s* \( \s* glob \s* \) /oxgc) {
849 0           return 'while ($_ = Char::Eusascii::glob_)';
850             }
851              
852             # while (glob(WILDCARD))
853             elsif (/\G \b while \s* \( \s* glob \b /oxgc) {
854 0           return 'while ($_ = Char::Eusascii::glob';
855             }
856              
857             # doit if, doit unless, doit while, doit until, doit for, doit when
858 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
859              
860             # subroutines of package Char::Eusascii
861 0           elsif (/\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
862 0           elsif (/\G \b bytes::substr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
863 0           elsif (/\G \b chop \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::chop'; }
  0            
864 0           elsif (/\G \b bytes::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
865 0           elsif (/\G \b Char::USASCII::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::USASCII::index'; }
  0            
866 0           elsif (/\G \b index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::index'; }
  0            
867 0           elsif (/\G \b bytes::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
868 0           elsif (/\G \b Char::USASCII::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::USASCII::rindex'; }
  0            
869 0           elsif (/\G \b rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::rindex'; }
  0            
870 0           elsif (/\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::lc'; }
  0            
871 0           elsif (/\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::lcfirst'; }
  0            
872 0           elsif (/\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::uc'; }
  0            
873 0           elsif (/\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::ucfirst'; }
  0            
874 0           elsif (/\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::fc'; }
  0            
875              
876             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
877 0           elsif (/\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
878 0           elsif (/\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
879 0           elsif (/\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
880 0           elsif (/\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
881 0           elsif (/\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
882 0           elsif (/\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
883 0           elsif (/\G -s \s+ qq \s* (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
884              
885 0           elsif (/\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
886 0           elsif (/\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
887 0           elsif (/\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
888 0           elsif (/\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
889 0           elsif (/\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
890 0           elsif (/\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
891 0           elsif (/\G -s \s+ q \s* (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
892              
893             elsif (/\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
894 0           { $slash = 'm//'; return "-s $1"; }
  0            
895 0           elsif (/\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
896 0           elsif (/\G -s (?= \s+ [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
897 0           elsif (/\G -s \s+ (\w+) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
898              
899 0           elsif (/\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
900 0           elsif (/\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
901 0           elsif (/\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::chr'; }
  0            
902 0           elsif (/\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
903 0           elsif (/\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
904 0           elsif (/\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::glob'; }
  0            
905 0           elsif (/\G \b lc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::lc_'; }
  0            
906 0           elsif (/\G \b lcfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::lcfirst_'; }
  0            
907 0           elsif (/\G \b uc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::uc_'; }
  0            
908 0           elsif (/\G \b ucfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::ucfirst_'; }
  0            
909 0           elsif (/\G \b fc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::fc_'; }
  0            
910 0           elsif (/\G -s \b (?! \s* => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
911              
912 0           elsif (/\G \b bytes::length \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
913 0           elsif (/\G \b bytes::chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
914 0           elsif (/\G \b chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::chr_'; }
  0            
915 0           elsif (/\G \b bytes::ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
916 0           elsif (/\G \b ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
917 0           elsif (/\G \b glob \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::glob_'; }
  0            
918 0           elsif (/\G \b reverse \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
919 0           elsif (/\G \b getc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
920              
921             # split
922             elsif (/\G \b (split) \b (?! \s* => ) /oxgc) {
923 0           $slash = 'm//';
924              
925 0           my $e = '';
926 0           while (/\G ( \s+ | \( | \#.* ) /oxgc) {
927 0           $e .= $1;
928             }
929              
930             # end of split
931 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Eusascii::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
932              
933             # split scalar value
934 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Char::Eusascii::split' . $e . e_string($1); }
935              
936             # split literal space
937 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Char::Eusascii::split' . $e . qq {qq$1 $2}; }
938 0           elsif (/\G \b qq (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; }
939 0           elsif (/\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; }
940 0           elsif (/\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; }
941 0           elsif (/\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; }
942 0           elsif (/\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; }
943 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Char::Eusascii::split' . $e . qq {q$1 $2}; }
944 0           elsif (/\G \b q (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; }
945 0           elsif (/\G \b q (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; }
946 0           elsif (/\G \b q (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; }
947 0           elsif (/\G \b q (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; }
948 0           elsif (/\G \b q (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; }
949 0           elsif (/\G ' [ ] ' /oxgc) { return 'Char::Eusascii::split' . $e . qq {' '}; }
950 0           elsif (/\G " [ ] " /oxgc) { return 'Char::Eusascii::split' . $e . qq {" "}; }
951              
952             # split qq//
953             elsif (/\G \b (qq) \b /oxgc) {
954 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
955             else {
956 0           while (not /\G \z/oxgc) {
957 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
958 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
959 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
960 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
961 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
962 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
963 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
964             }
965 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
966             }
967             }
968              
969             # split qr//
970             elsif (/\G \b (qr) \b /oxgc) {
971 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
972             else {
973 0           while (not /\G \z/oxgc) {
974 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
975 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
976 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
977 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
978 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
979 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
980 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
981 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
982             }
983 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
984             }
985             }
986              
987             # split q//
988             elsif (/\G \b (q) \b /oxgc) {
989 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
990             else {
991 0           while (not /\G \z/oxgc) {
992 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
993 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
994 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
995 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
996 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
997 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
998 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
999             }
1000 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1001             }
1002             }
1003              
1004             # split m//
1005             elsif (/\G \b (m) \b /oxgc) {
1006 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
1007             else {
1008 0           while (not /\G \z/oxgc) {
1009 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
1010 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
1011 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
1012 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
1013 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
1014 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
1015 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
1016 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
1017             }
1018 0           die __FILE__, ": Search pattern not terminated";
1019             }
1020             }
1021              
1022             # split ''
1023             elsif (/\G (\') /oxgc) {
1024 0           my $q_string = '';
1025 0           while (not /\G \z/oxgc) {
1026 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
1027 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
1028 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
1029 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
1030             }
1031 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1032             }
1033              
1034             # split ""
1035             elsif (/\G (\") /oxgc) {
1036 0           my $qq_string = '';
1037 0           while (not /\G \z/oxgc) {
1038 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
1039 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
1040 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
1041 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
1042             }
1043 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1044             }
1045              
1046             # split //
1047             elsif (/\G (\/) /oxgc) {
1048 0           my $regexp = '';
1049 0           while (not /\G \z/oxgc) {
1050 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
1051 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
1052 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
1053 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
1054             }
1055 0           die __FILE__, ": Search pattern not terminated";
1056             }
1057             }
1058              
1059             # tr/// or y///
1060              
1061             # about [cdsrbB]* (/B modifier)
1062             #
1063             # P.559 appendix C
1064             # of ISBN 4-89052-384-7 Programming perl
1065             # (Japanese title is: Perl puroguramingu)
1066              
1067             elsif (/\G \b ( tr | y ) \b /oxgc) {
1068 0           my $ope = $1;
1069              
1070             # $1 $2 $3 $4 $5 $6
1071 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
1072 0           my @tr = ($tr_variable,$2);
1073 0           return e_tr(@tr,'',$4,$6);
1074             }
1075             else {
1076 0           my $e = '';
1077 0           while (not /\G \z/oxgc) {
1078 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
1079             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
1080 0           my @tr = ($tr_variable,$2);
1081 0           while (not /\G \z/oxgc) {
1082 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
1083 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
1084 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
1085 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
1086 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
1087 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
1088             }
1089 0           die __FILE__, ": Transliteration replacement not terminated";
1090             }
1091             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
1092 0           my @tr = ($tr_variable,$2);
1093 0           while (not /\G \z/oxgc) {
1094 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
1095 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
1096 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
1097 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
1098 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
1099 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
1100             }
1101 0           die __FILE__, ": Transliteration replacement not terminated";
1102             }
1103             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
1104 0           my @tr = ($tr_variable,$2);
1105 0           while (not /\G \z/oxgc) {
1106 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
1107 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
1108 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
1109 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
1110 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
1111 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
1112             }
1113 0           die __FILE__, ": Transliteration replacement not terminated";
1114             }
1115             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
1116 0           my @tr = ($tr_variable,$2);
1117 0           while (not /\G \z/oxgc) {
1118 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
1119 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
1120 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
1121 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
1122 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
1123 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
1124             }
1125 0           die __FILE__, ": Transliteration replacement not terminated";
1126             }
1127             # $1 $2 $3 $4 $5 $6
1128             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
1129 0           my @tr = ($tr_variable,$2);
1130 0           return e_tr(@tr,'',$4,$6);
1131             }
1132             }
1133 0           die __FILE__, ": Transliteration pattern not terminated";
1134             }
1135             }
1136              
1137             # qq//
1138             elsif (/\G \b (qq) \b /oxgc) {
1139 0           my $ope = $1;
1140              
1141             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
1142 0 0         if (/\G (\#) /oxgc) { # qq# #
1143 0           my $qq_string = '';
1144 0           while (not /\G \z/oxgc) {
1145 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
1146 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
1147 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
1148 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
1149             }
1150 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1151             }
1152              
1153             else {
1154 0           my $e = '';
1155 0           while (not /\G \z/oxgc) {
1156 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
1157              
1158             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
1159             elsif (/\G (\() /oxgc) { # qq ( )
1160 0           my $qq_string = '';
1161 0           local $nest = 1;
1162 0           while (not /\G \z/oxgc) {
1163 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
1164 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
1165 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
1166             elsif (/\G (\)) /oxgc) {
1167 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
1168 0           else { $qq_string .= $1; }
1169             }
1170 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
1171             }
1172 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1173             }
1174              
1175             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
1176             elsif (/\G (\{) /oxgc) { # qq { }
1177 0           my $qq_string = '';
1178 0           local $nest = 1;
1179 0           while (not /\G \z/oxgc) {
1180 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
1181 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
1182 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
1183             elsif (/\G (\}) /oxgc) {
1184 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
1185 0           else { $qq_string .= $1; }
1186             }
1187 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
1188             }
1189 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1190             }
1191              
1192             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
1193             elsif (/\G (\[) /oxgc) { # qq [ ]
1194 0           my $qq_string = '';
1195 0           local $nest = 1;
1196 0           while (not /\G \z/oxgc) {
1197 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
1198 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
1199 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
1200             elsif (/\G (\]) /oxgc) {
1201 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
1202 0           else { $qq_string .= $1; }
1203             }
1204 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
1205             }
1206 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1207             }
1208              
1209             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
1210             elsif (/\G (\<) /oxgc) { # qq < >
1211 0           my $qq_string = '';
1212 0           local $nest = 1;
1213 0           while (not /\G \z/oxgc) {
1214 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
1215 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
1216 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
1217             elsif (/\G (\>) /oxgc) {
1218 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
1219 0           else { $qq_string .= $1; }
1220             }
1221 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
1222             }
1223 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1224             }
1225              
1226             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
1227             elsif (/\G (\S) /oxgc) { # qq * *
1228 0           my $delimiter = $1;
1229 0           my $qq_string = '';
1230 0           while (not /\G \z/oxgc) {
1231 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
1232 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
1233 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
1234 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
1235             }
1236 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1237             }
1238             }
1239 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1240             }
1241             }
1242              
1243             # qr//
1244             elsif (/\G \b (qr) \b /oxgc) {
1245 0           my $ope = $1;
1246 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { # qr# # #
1247 0           return e_qr($ope,$1,$3,$2,$4);
1248             }
1249             else {
1250 0           my $e = '';
1251 0           while (not /\G \z/oxgc) {
1252 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
1253 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
1254 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
1255 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
1256 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
1257 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
1258 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
1259 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
1260             }
1261 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1262             }
1263             }
1264              
1265             # qw//
1266             elsif (/\G \b (qw) \b /oxgc) {
1267 0           my $ope = $1;
1268 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
1269 0           return e_qw($ope,$1,$3,$2);
1270             }
1271             else {
1272 0           my $e = '';
1273 0           while (not /\G \z/oxgc) {
1274 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1275              
1276 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
1277 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
1278              
1279 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
1280 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
1281              
1282 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
1283 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
1284              
1285 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
1286 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
1287              
1288 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
1289 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
1290             }
1291 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1292             }
1293             }
1294              
1295             # qx//
1296             elsif (/\G \b (qx) \b /oxgc) {
1297 0           my $ope = $1;
1298 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
1299 0           return e_qq($ope,$1,$3,$2);
1300             }
1301             else {
1302 0           my $e = '';
1303 0           while (not /\G \z/oxgc) {
1304 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
1305 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
1306 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
1307 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
1308 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
1309 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
1310 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
1311             }
1312 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1313             }
1314             }
1315              
1316             # q//
1317             elsif (/\G \b (q) \b /oxgc) {
1318 0           my $ope = $1;
1319              
1320             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
1321              
1322             # avoid "Error: Runtime exception" of perl version 5.005_03
1323             # (and so on)
1324              
1325 0 0         if (/\G (\#) /oxgc) { # q# #
1326 0           my $q_string = '';
1327 0           while (not /\G \z/oxgc) {
1328 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
1329 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
1330 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
1331 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
1332             }
1333 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1334             }
1335              
1336             else {
1337 0           my $e = '';
1338 0           while (not /\G \z/oxgc) {
1339 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
1340              
1341             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
1342             elsif (/\G (\() /oxgc) { # q ( )
1343 0           my $q_string = '';
1344 0           local $nest = 1;
1345 0           while (not /\G \z/oxgc) {
1346 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
1347 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
1348 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
1349 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
1350             elsif (/\G (\)) /oxgc) {
1351 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
1352 0           else { $q_string .= $1; }
1353             }
1354 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
1355             }
1356 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1357             }
1358              
1359             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
1360             elsif (/\G (\{) /oxgc) { # q { }
1361 0           my $q_string = '';
1362 0           local $nest = 1;
1363 0           while (not /\G \z/oxgc) {
1364 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
1365 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
1366 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
1367 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
1368             elsif (/\G (\}) /oxgc) {
1369 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
1370 0           else { $q_string .= $1; }
1371             }
1372 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
1373             }
1374 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1375             }
1376              
1377             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
1378             elsif (/\G (\[) /oxgc) { # q [ ]
1379 0           my $q_string = '';
1380 0           local $nest = 1;
1381 0           while (not /\G \z/oxgc) {
1382 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
1383 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
1384 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
1385 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
1386             elsif (/\G (\]) /oxgc) {
1387 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
1388 0           else { $q_string .= $1; }
1389             }
1390 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
1391             }
1392 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1393             }
1394              
1395             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
1396             elsif (/\G (\<) /oxgc) { # q < >
1397 0           my $q_string = '';
1398 0           local $nest = 1;
1399 0           while (not /\G \z/oxgc) {
1400 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
1401 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
1402 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
1403 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
1404             elsif (/\G (\>) /oxgc) {
1405 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
1406 0           else { $q_string .= $1; }
1407             }
1408 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
1409             }
1410 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1411             }
1412              
1413             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
1414             elsif (/\G (\S) /oxgc) { # q * *
1415 0           my $delimiter = $1;
1416 0           my $q_string = '';
1417 0           while (not /\G \z/oxgc) {
1418 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
1419 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
1420 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
1421 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
1422             }
1423 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1424             }
1425             }
1426 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1427             }
1428             }
1429              
1430             # m//
1431             elsif (/\G \b (m) \b /oxgc) {
1432 0           my $ope = $1;
1433 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { # m# #
1434 0           return e_qr($ope,$1,$3,$2,$4);
1435             }
1436             else {
1437 0           my $e = '';
1438 0           while (not /\G \z/oxgc) {
1439 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1440 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
1441 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
1442 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
1443 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
1444 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
1445 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
1446 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
1447 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
1448             }
1449 0           die __FILE__, ": Search pattern not terminated";
1450             }
1451             }
1452              
1453             # s///
1454              
1455             # about [cegimosxpradlubB]* (/cg modifier)
1456             #
1457             # P.67 Pattern-Matching Operators
1458             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
1459              
1460             elsif (/\G \b (s) \b /oxgc) {
1461 0           my $ope = $1;
1462              
1463             # $1 $2 $3 $4 $5 $6
1464 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlubB]*) /oxgc) { # s# # #
1465 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
1466             }
1467             else {
1468 0           my $e = '';
1469 0           while (not /\G \z/oxgc) {
1470 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1471             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
1472 0           my @s = ($1,$2,$3);
1473 0           while (not /\G \z/oxgc) {
1474 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1475             # $1 $2 $3 $4
1476 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1477 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1478 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1479 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1480 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1481 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1482 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1483 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1484 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1485             }
1486 0           die __FILE__, ": Substitution replacement not terminated";
1487             }
1488             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
1489 0           my @s = ($1,$2,$3);
1490 0           while (not /\G \z/oxgc) {
1491 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1492             # $1 $2 $3 $4
1493 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1494 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1495 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1496 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1497 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1498 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1499 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1500 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1501 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1502             }
1503 0           die __FILE__, ": Substitution replacement not terminated";
1504             }
1505             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
1506 0           my @s = ($1,$2,$3);
1507 0           while (not /\G \z/oxgc) {
1508 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
1509             # $1 $2 $3 $4
1510 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1511 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1512 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1513 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1514 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1515 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1516 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1517             }
1518 0           die __FILE__, ": Substitution replacement not terminated";
1519             }
1520             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
1521 0           my @s = ($1,$2,$3);
1522 0           while (not /\G \z/oxgc) {
1523 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1524             # $1 $2 $3 $4
1525 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1526 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1527 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1528 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1529 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1530 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1531 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1532 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1533 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
1534             }
1535 0           die __FILE__, ": Substitution replacement not terminated";
1536             }
1537             # $1 $2 $3 $4 $5 $6
1538             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) {
1539 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
1540             }
1541             # $1 $2 $3 $4 $5 $6
1542             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
1543 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
1544             }
1545             # $1 $2 $3 $4 $5 $6
1546             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
1547 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
1548             }
1549             # $1 $2 $3 $4 $5 $6
1550             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
1551 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
1552             }
1553             }
1554 0           die __FILE__, ": Substitution pattern not terminated";
1555             }
1556             }
1557              
1558             # require ignore module
1559 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
1560 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
1561 0           elsif (/\G \b require (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
1562              
1563             # use strict; --> use strict; no strict qw(refs);
1564 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
1565 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
1566 0           elsif (/\G \b use (\s+ strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
1567              
1568             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
1569             elsif (/\G \b use \s+ (([1-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
1570 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
1571 0           return "use $1; no strict qw(refs);";
1572             }
1573             else {
1574 0           return "use $1;";
1575             }
1576             }
1577             elsif (/\G \b use \s+ (v([0-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
1578 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
1579 0           return "use $1; no strict qw(refs);";
1580             }
1581             else {
1582 0           return "use $1;";
1583             }
1584             }
1585              
1586             # ignore use module
1587 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
1588 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
1589 0           elsif (/\G \b use (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
1590              
1591             # ignore no module
1592 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
1593 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
1594 0           elsif (/\G \b no (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
1595              
1596             # use else
1597 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
1598              
1599             # use else
1600 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
1601              
1602             # ''
1603             elsif (/\G (?
1604 0           my $q_string = '';
1605 0           while (not /\G \z/oxgc) {
1606 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
1607 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
1608 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
1609 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
1610             }
1611 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1612             }
1613              
1614             # ""
1615             elsif (/\G (\") /oxgc) {
1616 0           my $qq_string = '';
1617 0           while (not /\G \z/oxgc) {
1618 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
1619 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
1620 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
1621 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
1622             }
1623 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1624             }
1625              
1626             # ``
1627             elsif (/\G (\`) /oxgc) {
1628 0           my $qx_string = '';
1629 0           while (not /\G \z/oxgc) {
1630 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
1631 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
1632 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
1633 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
1634             }
1635 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
1636             }
1637              
1638             # // --- not divide operator (num / num), not defined-or
1639             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
1640 0           my $regexp = '';
1641 0           while (not /\G \z/oxgc) {
1642 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
1643 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
1644 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
1645 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
1646             }
1647 0           die __FILE__, ": Search pattern not terminated";
1648             }
1649              
1650             # ?? --- not conditional operator (condition ? then : else)
1651             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
1652 0           my $regexp = '';
1653 0           while (not /\G \z/oxgc) {
1654 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
1655 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
1656 0           elsif (/\G \? ([cgimosxpadlubB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
1657 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
1658             }
1659 0           die __FILE__, ": Search pattern not terminated";
1660             }
1661              
1662             # << (bit shift) --- not here document
1663 0           elsif (/\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
1664              
1665             # <<'HEREDOC'
1666             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
1667 0           $slash = 'm//';
1668 0           my $here_quote = $1;
1669 0           my $delimiter = $2;
1670              
1671             # get here document
1672 0 0         if ($here_script eq '') {
1673 0           $here_script = CORE::substr $_, pos $_;
1674 0           $here_script =~ s/.*?\n//oxm;
1675             }
1676 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
1677 0           push @heredoc, $1 . qq{\n$delimiter\n};
1678 0           push @heredoc_delimiter, $delimiter;
1679             }
1680             else {
1681 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
1682             }
1683 0           return $here_quote;
1684             }
1685              
1686             # <<\HEREDOC
1687              
1688             # P.66 2.6.6. "Here" Documents
1689             # in Chapter 2: Bits and Pieces
1690             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1691              
1692             # P.73 "Here" Documents
1693             # in Chapter 2: Bits and Pieces
1694             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1695              
1696             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
1697 0           $slash = 'm//';
1698 0           my $here_quote = $1;
1699 0           my $delimiter = $2;
1700              
1701             # get here document
1702 0 0         if ($here_script eq '') {
1703 0           $here_script = CORE::substr $_, pos $_;
1704 0           $here_script =~ s/.*?\n//oxm;
1705             }
1706 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
1707 0           push @heredoc, $1 . qq{\n$delimiter\n};
1708 0           push @heredoc_delimiter, $delimiter;
1709             }
1710             else {
1711 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
1712             }
1713 0           return $here_quote;
1714             }
1715              
1716             # <<"HEREDOC"
1717             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
1718 0           $slash = 'm//';
1719 0           my $here_quote = $1;
1720 0           my $delimiter = $2;
1721              
1722             # get here document
1723 0 0         if ($here_script eq '') {
1724 0           $here_script = CORE::substr $_, pos $_;
1725 0           $here_script =~ s/.*?\n//oxm;
1726             }
1727 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
1728 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
1729 0           push @heredoc_delimiter, $delimiter;
1730             }
1731             else {
1732 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
1733             }
1734 0           return $here_quote;
1735             }
1736              
1737             # <
1738             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
1739 0           $slash = 'm//';
1740 0           my $here_quote = $1;
1741 0           my $delimiter = $2;
1742              
1743             # get here document
1744 0 0         if ($here_script eq '') {
1745 0           $here_script = CORE::substr $_, pos $_;
1746 0           $here_script =~ s/.*?\n//oxm;
1747             }
1748 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
1749 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
1750 0           push @heredoc_delimiter, $delimiter;
1751             }
1752             else {
1753 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
1754             }
1755 0           return $here_quote;
1756             }
1757              
1758             # <<`HEREDOC`
1759             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
1760 0           $slash = 'm//';
1761 0           my $here_quote = $1;
1762 0           my $delimiter = $2;
1763              
1764             # get here document
1765 0 0         if ($here_script eq '') {
1766 0           $here_script = CORE::substr $_, pos $_;
1767 0           $here_script =~ s/.*?\n//oxm;
1768             }
1769 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
1770 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
1771 0           push @heredoc_delimiter, $delimiter;
1772             }
1773             else {
1774 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
1775             }
1776 0           return $here_quote;
1777             }
1778              
1779             # <<= <=> <= < operator
1780             elsif (/\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
1781 0           return $1;
1782             }
1783              
1784             #
1785             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
1786 0           return $1;
1787             }
1788              
1789             # --- glob
1790              
1791             # avoid "Error: Runtime exception" of perl version 5.005_03
1792              
1793             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
1794 0           return 'Char::Eusascii::glob("' . $1 . '")';
1795             }
1796              
1797             # __DATA__
1798 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
1799              
1800             # __END__
1801 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
1802              
1803             # \cD Control-D
1804              
1805             # P.68 2.6.8. Other Literal Tokens
1806             # in Chapter 2: Bits and Pieces
1807             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1808              
1809             # P.76 Other Literal Tokens
1810             # in Chapter 2: Bits and Pieces
1811             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1812              
1813 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
1814              
1815             # \cZ Control-Z
1816 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
1817              
1818             # any operator before div
1819             elsif (/\G (
1820             -- | \+\+ |
1821             [\)\}\]]
1822              
1823 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
1824              
1825             # yada-yada or triple-dot operator
1826             elsif (/\G (
1827             \.\.\.
1828              
1829 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
1830              
1831             # any operator before m//
1832              
1833             # //, //= (defined-or)
1834              
1835             # P.164 Logical Operators
1836             # in Chapter 10: More Control Structures
1837             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1838              
1839             # P.119 C-Style Logical (Short-Circuit) Operators
1840             # in Chapter 3: Unary and Binary Operators
1841             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1842              
1843             # (and so on)
1844              
1845             # ~~
1846              
1847             # P.221 The Smart Match Operator
1848             # in Chapter 15: Smart Matching and given-when
1849             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1850              
1851             # P.112 Smartmatch Operator
1852             # in Chapter 3: Unary and Binary Operators
1853             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1854              
1855             # (and so on)
1856              
1857             elsif (/\G (
1858              
1859             !~~ | !~ | != | ! |
1860             %= | % |
1861             &&= | && | &= | & |
1862             -= | -> | - |
1863             :\s*= |
1864             : |
1865             <<= | <=> | <= | < |
1866             == | => | =~ | = |
1867             >>= | >> | >= | > |
1868             \*\*= | \*\* | \*= | \* |
1869             \+= | \+ |
1870             \.\. | \.= | \. |
1871             \/\/= | \/\/ |
1872             \/= | \/ |
1873             \? |
1874             \\ |
1875             \^= | \^ |
1876             \b x= |
1877             \|\|= | \|\| | \|= | \| |
1878             ~~ | ~ |
1879             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
1880             \b(?: print )\b |
1881              
1882             [,;\(\{\[]
1883              
1884 0           ) /oxgc) { $slash = 'm//'; return $1; }
  0            
1885              
1886             # other any character
1887 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
1888              
1889             # system error
1890             else {
1891 0           die __FILE__, ": Oops, this shouldn't happen!";
1892             }
1893             }
1894              
1895             # escape US-ASCII string
1896             sub e_string {
1897 0     0 0   my($string) = @_;
1898 0           my $e_string = '';
1899              
1900 0           local $slash = 'm//';
1901              
1902             # P.1024 Appendix W.10 Multibyte Processing
1903             # of ISBN 1-56592-224-7 CJKV Information Processing
1904             # (and so on)
1905              
1906 0           my @char = $string =~ / \G (\\?(?:$q_char)) /oxmsg;
1907              
1908             # without { ... }
1909 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
1910 0 0         if ($string !~ /<
1911 0           return $string;
1912             }
1913             }
1914              
1915             E_STRING_LOOP:
1916 0           while ($string !~ /\G \z/oxgc) {
1917 0 0         if (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          
    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          
1918             }
1919              
1920             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Char::Eusascii::PREMATCH()]}
1921 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
1922 0           $e_string .= q{Char::Eusascii::PREMATCH()};
1923 0           $slash = 'div';
1924             }
1925              
1926             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Char::Eusascii::MATCH()]}
1927             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
1928 0           $e_string .= q{Char::Eusascii::MATCH()};
1929 0           $slash = 'div';
1930             }
1931              
1932             # $', ${'} --> $', ${'}
1933             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
1934 0           $e_string .= $1;
1935 0           $slash = 'div';
1936             }
1937              
1938             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Char::Eusascii::POSTMATCH()]}
1939             elsif ($string =~ /\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
1940 0           $e_string .= q{Char::Eusascii::POSTMATCH()};
1941 0           $slash = 'div';
1942             }
1943              
1944             # bareword
1945             elsif ($string =~ /\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
1946 0           $e_string .= $1;
1947 0           $slash = 'div';
1948             }
1949              
1950             # $0 --> $0
1951             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
1952 0           $e_string .= $1;
1953 0           $slash = 'div';
1954             }
1955             elsif ($string =~ /\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
1956 0           $e_string .= $1;
1957 0           $slash = 'div';
1958             }
1959              
1960             # $$ --> $$
1961             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
1962 0           $e_string .= $1;
1963 0           $slash = 'div';
1964             }
1965              
1966             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
1967             # $1, $2, $3 --> $1, $2, $3 otherwise
1968             elsif ($string =~ /\G \$ ([1-9][0-9]*) /oxmsgc) {
1969 0           $e_string .= e_capture($1);
1970 0           $slash = 'div';
1971             }
1972             elsif ($string =~ /\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
1973 0           $e_string .= e_capture($1);
1974 0           $slash = 'div';
1975             }
1976              
1977             # $$foo[ ... ] --> $ $foo->[ ... ]
1978             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
1979 0           $e_string .= e_capture($1.'->'.$2);
1980 0           $slash = 'div';
1981             }
1982              
1983             # $$foo{ ... } --> $ $foo->{ ... }
1984             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
1985 0           $e_string .= e_capture($1.'->'.$2);
1986 0           $slash = 'div';
1987             }
1988              
1989             # $$foo
1990             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
1991 0           $e_string .= e_capture($1);
1992 0           $slash = 'div';
1993             }
1994              
1995             # ${ foo }
1996             elsif ($string =~ /\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
1997 0           $e_string .= '${' . $1 . '}';
1998 0           $slash = 'div';
1999             }
2000              
2001             # ${ ... }
2002             elsif ($string =~ /\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
2003 0           $e_string .= e_capture($1);
2004 0           $slash = 'div';
2005             }
2006              
2007             # variable or function
2008             # $ @ % & * $ #
2009             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) {
2010 0           $e_string .= $1;
2011 0           $slash = 'div';
2012             }
2013             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
2014             # $ @ # \ ' " / ? ( ) [ ] < >
2015             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
2016 0           $e_string .= $1;
2017 0           $slash = 'div';
2018             }
2019              
2020             # subroutines of package Char::Eusascii
2021 0           elsif ($string =~ /\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
2022 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
2023 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Char::Eusascii::chop'; $slash = 'm//'; }
  0            
2024 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
2025 0           elsif ($string =~ /\G \b Char::USASCII::index \b /oxgc) { $e_string .= 'Char::USASCII::index'; $slash = 'm//'; }
  0            
2026 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Char::Eusascii::index'; $slash = 'm//'; }
  0            
2027 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
2028 0           elsif ($string =~ /\G \b Char::USASCII::rindex \b /oxgc) { $e_string .= 'Char::USASCII::rindex'; $slash = 'm//'; }
  0            
2029 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Char::Eusascii::rindex'; $slash = 'm//'; }
  0            
2030 0           elsif ($string =~ /\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::lc'; $slash = 'm//'; }
  0            
2031 0           elsif ($string =~ /\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::lcfirst'; $slash = 'm//'; }
  0            
2032 0           elsif ($string =~ /\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::uc'; $slash = 'm//'; }
  0            
2033 0           elsif ($string =~ /\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::ucfirst'; $slash = 'm//'; }
  0            
2034 0           elsif ($string =~ /\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::fc'; $slash = 'm//'; }
  0            
2035              
2036             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
2037 0           elsif ($string =~ /\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
2038 0           elsif ($string =~ /\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
2039 0           elsif ($string =~ /\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
2040 0           elsif ($string =~ /\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
2041 0           elsif ($string =~ /\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
2042 0           elsif ($string =~ /\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
2043 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            
2044              
2045 0           elsif ($string =~ /\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
2046 0           elsif ($string =~ /\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
2047 0           elsif ($string =~ /\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
2048 0           elsif ($string =~ /\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
2049 0           elsif ($string =~ /\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
2050 0           elsif ($string =~ /\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
2051 0           elsif ($string =~ /\G -s \s+ q \s* (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
2052              
2053             elsif ($string =~ /\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
2054 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
2055 0           elsif ($string =~ /\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
2056 0           elsif ($string =~ /\G -s (?= \s+ [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
2057 0           elsif ($string =~ /\G -s \s+ (\w+) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
2058              
2059 0           elsif ($string =~ /\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
2060 0           elsif ($string =~ /\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
2061 0           elsif ($string =~ /\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::chr'; $slash = 'm//'; }
  0            
2062 0           elsif ($string =~ /\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
2063 0           elsif ($string =~ /\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
2064 0           elsif ($string =~ /\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::glob'; $slash = 'm//'; }
  0            
2065 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Char::Eusascii::lc_'; $slash = 'm//'; }
  0            
2066 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Char::Eusascii::lcfirst_'; $slash = 'm//'; }
  0            
2067 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Char::Eusascii::uc_'; $slash = 'm//'; }
  0            
2068 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Char::Eusascii::ucfirst_'; $slash = 'm//'; }
  0            
2069 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Char::Eusascii::fc_'; $slash = 'm//'; }
  0            
2070 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
2071              
2072 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
2073 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
2074 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Char::Eusascii::chr_'; $slash = 'm//'; }
  0            
2075 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
2076 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
2077 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Char::Eusascii::glob_'; $slash = 'm//'; }
  0            
2078 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
2079 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
2080              
2081             # split
2082             elsif ($string =~ /\G \b (split) \b (?! \s* => ) /oxgc) {
2083 0           $slash = 'm//';
2084              
2085 0           my $e = '';
2086 0           while ($string =~ /\G ( \s+ | \( | \#.* ) /oxgc) {
2087 0           $e .= $1;
2088             }
2089              
2090             # end of split
2091 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Eusascii::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
2092              
2093             # split scalar value
2094 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
2095              
2096             # split literal space
2097 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
2098 0           elsif ($string =~ /\G \b qq (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
2099 0           elsif ($string =~ /\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
2100 0           elsif ($string =~ /\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
2101 0           elsif ($string =~ /\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
2102 0           elsif ($string =~ /\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
2103 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
2104 0           elsif ($string =~ /\G \b q (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
2105 0           elsif ($string =~ /\G \b q (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
2106 0           elsif ($string =~ /\G \b q (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
2107 0           elsif ($string =~ /\G \b q (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
2108 0           elsif ($string =~ /\G \b q (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
2109 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
2110 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
2111              
2112             # split qq//
2113             elsif ($string =~ /\G \b (qq) \b /oxgc) {
2114 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
  0            
  0            
2115             else {
2116 0           while ($string !~ /\G \z/oxgc) {
2117 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
2118 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
2119 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
2120 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
2121 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
2122 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
2123 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
  0            
2124             }
2125 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
2126             }
2127             }
2128              
2129             # split qr//
2130             elsif ($string =~ /\G \b (qr) \b /oxgc) {
2131 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0            
  0            
2132             else {
2133 0           while ($string !~ /\G \z/oxgc) {
2134 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
2135 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
2136 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
2137 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
2138 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
2139 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0            
2140 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
2141 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
  0            
2142             }
2143 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
2144             }
2145             }
2146              
2147             # split q//
2148             elsif ($string =~ /\G \b (q) \b /oxgc) {
2149 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
  0            
  0            
2150             else {
2151 0           while ($string !~ /\G \z/oxgc) {
2152 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
2153 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
2154 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
2155 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
2156 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
2157 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
2158 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 * *
  0            
2159             }
2160 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
2161             }
2162             }
2163              
2164             # split m//
2165             elsif ($string =~ /\G \b (m) \b /oxgc) {
2166 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
  0            
  0            
2167             else {
2168 0           while ($string !~ /\G \z/oxgc) {
2169 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
2170 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0            
2171 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0            
2172 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0            
2173 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0            
2174 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0            
2175 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
2176 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
  0            
2177             }
2178 0           die __FILE__, ": Search pattern not terminated";
2179             }
2180             }
2181              
2182             # split ''
2183             elsif ($string =~ /\G (\') /oxgc) {
2184 0           my $q_string = '';
2185 0           while ($string !~ /\G \z/oxgc) {
2186 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
2187 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
2188 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
2189 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
2190             }
2191 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
2192             }
2193              
2194             # split ""
2195             elsif ($string =~ /\G (\") /oxgc) {
2196 0           my $qq_string = '';
2197 0           while ($string !~ /\G \z/oxgc) {
2198 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
2199 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
2200 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
2201 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
2202             }
2203 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
2204             }
2205              
2206             # split //
2207             elsif ($string =~ /\G (\/) /oxgc) {
2208 0           my $regexp = '';
2209 0           while ($string !~ /\G \z/oxgc) {
2210 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
2211 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
2212 0           elsif ($string =~ /\G \/ ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
2213 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
2214             }
2215 0           die __FILE__, ": Search pattern not terminated";
2216             }
2217             }
2218              
2219             # qq//
2220             elsif ($string =~ /\G \b (qq) \b /oxgc) {
2221 0           my $ope = $1;
2222 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
2223 0           $e_string .= e_qq($ope,$1,$3,$2);
2224             }
2225             else {
2226 0           my $e = '';
2227 0           while ($string !~ /\G \z/oxgc) {
2228 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
2229 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
2230 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
2231 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
2232 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
2233 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
2234             }
2235 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
2236             }
2237             }
2238              
2239             # qx//
2240             elsif ($string =~ /\G \b (qx) \b /oxgc) {
2241 0           my $ope = $1;
2242 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
2243 0           $e_string .= e_qq($ope,$1,$3,$2);
2244             }
2245             else {
2246 0           my $e = '';
2247 0           while ($string !~ /\G \z/oxgc) {
2248 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
2249 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
2250 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
2251 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
2252 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
2253 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
2254 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
2255             }
2256 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
2257             }
2258             }
2259              
2260             # q//
2261             elsif ($string =~ /\G \b (q) \b /oxgc) {
2262 0           my $ope = $1;
2263 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
2264 0           $e_string .= e_q($ope,$1,$3,$2);
2265             }
2266             else {
2267 0           my $e = '';
2268 0           while ($string !~ /\G \z/oxgc) {
2269 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
2270 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
2271 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
2272 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
2273 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
2274 0           elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
  0            
2275             }
2276 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
2277             }
2278             }
2279              
2280             # ''
2281 0           elsif ($string =~ /\G (?
2282              
2283             # ""
2284 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
2285              
2286             # ``
2287 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
2288              
2289             # <<= <=> <= < operator
2290             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc)
2291 0           { $e_string .= $1; }
2292              
2293             #
2294 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
2295              
2296             # --- glob
2297             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
2298 0           $e_string .= 'Char::Eusascii::glob("' . $1 . '")';
2299             }
2300              
2301             # << (bit shift) --- not here document
2302 0           elsif ($string =~ /\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
2303              
2304             # <<'HEREDOC'
2305             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
2306 0           $slash = 'm//';
2307 0           my $here_quote = $1;
2308 0           my $delimiter = $2;
2309              
2310             # get here document
2311 0 0         if ($here_script eq '') {
2312 0           $here_script = CORE::substr $_, pos $_;
2313 0           $here_script =~ s/.*?\n//oxm;
2314             }
2315 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
2316 0           push @heredoc, $1 . qq{\n$delimiter\n};
2317 0           push @heredoc_delimiter, $delimiter;
2318             }
2319             else {
2320 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
2321             }
2322 0           $e_string .= $here_quote;
2323             }
2324              
2325             # <<\HEREDOC
2326             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
2327 0           $slash = 'm//';
2328 0           my $here_quote = $1;
2329 0           my $delimiter = $2;
2330              
2331             # get here document
2332 0 0         if ($here_script eq '') {
2333 0           $here_script = CORE::substr $_, pos $_;
2334 0           $here_script =~ s/.*?\n//oxm;
2335             }
2336 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
2337 0           push @heredoc, $1 . qq{\n$delimiter\n};
2338 0           push @heredoc_delimiter, $delimiter;
2339             }
2340             else {
2341 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
2342             }
2343 0           $e_string .= $here_quote;
2344             }
2345              
2346             # <<"HEREDOC"
2347             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
2348 0           $slash = 'm//';
2349 0           my $here_quote = $1;
2350 0           my $delimiter = $2;
2351              
2352             # get here document
2353 0 0         if ($here_script eq '') {
2354 0           $here_script = CORE::substr $_, pos $_;
2355 0           $here_script =~ s/.*?\n//oxm;
2356             }
2357 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
2358 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
2359 0           push @heredoc_delimiter, $delimiter;
2360             }
2361             else {
2362 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
2363             }
2364 0           $e_string .= $here_quote;
2365             }
2366              
2367             # <
2368             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
2369 0           $slash = 'm//';
2370 0           my $here_quote = $1;
2371 0           my $delimiter = $2;
2372              
2373             # get here document
2374 0 0         if ($here_script eq '') {
2375 0           $here_script = CORE::substr $_, pos $_;
2376 0           $here_script =~ s/.*?\n//oxm;
2377             }
2378 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
2379 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
2380 0           push @heredoc_delimiter, $delimiter;
2381             }
2382             else {
2383 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
2384             }
2385 0           $e_string .= $here_quote;
2386             }
2387              
2388             # <<`HEREDOC`
2389             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
2390 0           $slash = 'm//';
2391 0           my $here_quote = $1;
2392 0           my $delimiter = $2;
2393              
2394             # get here document
2395 0 0         if ($here_script eq '') {
2396 0           $here_script = CORE::substr $_, pos $_;
2397 0           $here_script =~ s/.*?\n//oxm;
2398             }
2399 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
2400 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
2401 0           push @heredoc_delimiter, $delimiter;
2402             }
2403             else {
2404 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
2405             }
2406 0           $e_string .= $here_quote;
2407             }
2408              
2409             # any operator before div
2410             elsif ($string =~ /\G (
2411             -- | \+\+ |
2412             [\)\}\]]
2413              
2414 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
2415              
2416             # yada-yada or triple-dot operator
2417             elsif ($string =~ /\G (
2418             \.\.\.
2419              
2420 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
2421              
2422             # any operator before m//
2423             elsif ($string =~ /\G (
2424              
2425             !~~ | !~ | != | ! |
2426             %= | % |
2427             &&= | && | &= | & |
2428             -= | -> | - |
2429             :\s*= |
2430             : |
2431             <<= | <=> | <= | < |
2432             == | => | =~ | = |
2433             >>= | >> | >= | > |
2434             \*\*= | \*\* | \*= | \* |
2435             \+= | \+ |
2436             \.\. | \.= | \. |
2437             \/\/= | \/\/ |
2438             \/= | \/ |
2439             \? |
2440             \\ |
2441             \^= | \^ |
2442             \b x= |
2443             \|\|= | \|\| | \|= | \| |
2444             ~~ | ~ |
2445             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
2446             \b(?: print )\b |
2447              
2448             [,;\(\{\[]
2449              
2450 0           ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
2451              
2452             # other any character
2453 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
2454              
2455             # system error
2456             else {
2457 0           die __FILE__, ": Oops, this shouldn't happen!";
2458             }
2459             }
2460              
2461 0           return $e_string;
2462             }
2463              
2464             #
2465             # character class
2466             #
2467             sub character_class {
2468 0     0 0   my($char,$modifier) = @_;
2469              
2470 0 0         if ($char eq '.') {
2471 0 0         if ($modifier =~ /s/) {
2472 0           return '${Char::Eusascii::dot_s}';
2473             }
2474             else {
2475 0           return '${Char::Eusascii::dot}';
2476             }
2477             }
2478             else {
2479 0           return Char::Eusascii::classic_character_class($char);
2480             }
2481             }
2482              
2483             #
2484             # escape capture ($1, $2, $3, ...)
2485             #
2486             sub e_capture {
2487              
2488 0     0 0   return join '', '${', $_[0], '}';
2489             }
2490              
2491             #
2492             # escape transliteration (tr/// or y///)
2493             #
2494             sub e_tr {
2495 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
2496 0           my $e_tr = '';
2497 0   0       $modifier ||= '';
2498              
2499 0           $slash = 'div';
2500              
2501             # quote character class 1
2502 0           $charclass = q_tr($charclass);
2503              
2504             # quote character class 2
2505 0           $charclass2 = q_tr($charclass2);
2506              
2507             # /b /B modifier
2508 0 0         if ($modifier =~ tr/bB//d) {
2509 0 0         if ($variable eq '') {
2510 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
2511             }
2512             else {
2513 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
2514             }
2515             }
2516             else {
2517 0 0         if ($variable eq '') {
2518 0           $e_tr = qq{Char::Eusascii::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
2519             }
2520             else {
2521 0           $e_tr = qq{Char::Eusascii::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
2522             }
2523             }
2524              
2525             # clear tr/// variable
2526 0           $tr_variable = '';
2527 0           $bind_operator = '';
2528              
2529 0           return $e_tr;
2530             }
2531              
2532             #
2533             # quote for escape transliteration (tr/// or y///)
2534             #
2535             sub q_tr {
2536 0     0 0   my($charclass) = @_;
2537              
2538             # quote character class
2539 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
2540 0           return e_q('', "'", "'", $charclass); # --> q' '
2541             }
2542             elsif ($charclass !~ /\//oxms) {
2543 0           return e_q('q', '/', '/', $charclass); # --> q/ /
2544             }
2545             elsif ($charclass !~ /\#/oxms) {
2546 0           return e_q('q', '#', '#', $charclass); # --> q# #
2547             }
2548             elsif ($charclass !~ /[\<\>]/oxms) {
2549 0           return e_q('q', '<', '>', $charclass); # --> q< >
2550             }
2551             elsif ($charclass !~ /[\(\)]/oxms) {
2552 0           return e_q('q', '(', ')', $charclass); # --> q( )
2553             }
2554             elsif ($charclass !~ /[\{\}]/oxms) {
2555 0           return e_q('q', '{', '}', $charclass); # --> q{ }
2556             }
2557             else {
2558 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
2559 0 0         if ($charclass !~ /\Q$char\E/xms) {
2560 0           return e_q('q', $char, $char, $charclass);
2561             }
2562             }
2563             }
2564              
2565 0           return e_q('q', '{', '}', $charclass);
2566             }
2567              
2568             #
2569             # escape q string (q//, '')
2570             #
2571             sub e_q {
2572 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
2573              
2574 0           $slash = 'div';
2575              
2576 0           return join '', $ope, $delimiter, $string, $end_delimiter;
2577             }
2578              
2579             #
2580             # escape qq string (qq//, "", qx//, ``)
2581             #
2582             sub e_qq {
2583 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
2584              
2585 0           $slash = 'div';
2586              
2587 0           my $left_e = 0;
2588 0           my $right_e = 0;
2589 0           my @char = $string =~ /\G(
2590             \\o\{ [0-7]+ \} |
2591             \\x\{ [0-9A-Fa-f]+ \} |
2592             \\N\{ [^0-9\}][^\}]* \} |
2593             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
2594             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
2595             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
2596             \$ \s* \d+ |
2597             \$ \s* \{ \s* \d+ \s* \} |
2598             \$ \$ (?![\w\{]) |
2599             \$ \s* \$ \s* $qq_variable |
2600             \\?(?:$q_char)
2601             )/oxmsg;
2602              
2603 0           for (my $i=0; $i <= $#char; $i++) {
2604              
2605             # "\L\u" --> "\u\L"
2606 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
2607 0           @char[$i,$i+1] = @char[$i+1,$i];
2608             }
2609              
2610             # "\U\l" --> "\l\U"
2611             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
2612 0           @char[$i,$i+1] = @char[$i+1,$i];
2613             }
2614              
2615             # octal escape sequence
2616             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
2617 0           $char[$i] = Char::Eusascii::octchr($1);
2618             }
2619              
2620             # hexadecimal escape sequence
2621             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
2622 0           $char[$i] = Char::Eusascii::hexchr($1);
2623             }
2624              
2625             # \N{CHARNAME} --> N{CHARNAME}
2626             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
2627 0           $char[$i] = $1;
2628             }
2629              
2630 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
2631             }
2632              
2633             # \F
2634             #
2635             # P.69 Table 2-6. Translation escapes
2636             # in Chapter 2: Bits and Pieces
2637             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2638             # (and so on)
2639              
2640             # \u \l \U \L \F \Q \E
2641 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
2642 0 0         if ($right_e < $left_e) {
2643 0           $char[$i] = '\\' . $char[$i];
2644             }
2645             }
2646             elsif ($char[$i] eq '\u') {
2647              
2648             # "STRING @{[ LIST EXPR ]} MORE STRING"
2649              
2650             # P.257 Other Tricks You Can Do with Hard References
2651             # in Chapter 8: References
2652             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2653              
2654             # P.353 Other Tricks You Can Do with Hard References
2655             # in Chapter 8: References
2656             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2657              
2658             # (and so on)
2659              
2660 0           $char[$i] = '@{[Char::Eusascii::ucfirst qq<';
2661 0           $left_e++;
2662             }
2663             elsif ($char[$i] eq '\l') {
2664 0           $char[$i] = '@{[Char::Eusascii::lcfirst qq<';
2665 0           $left_e++;
2666             }
2667             elsif ($char[$i] eq '\U') {
2668 0           $char[$i] = '@{[Char::Eusascii::uc qq<';
2669 0           $left_e++;
2670             }
2671             elsif ($char[$i] eq '\L') {
2672 0           $char[$i] = '@{[Char::Eusascii::lc qq<';
2673 0           $left_e++;
2674             }
2675             elsif ($char[$i] eq '\F') {
2676 0           $char[$i] = '@{[Char::Eusascii::fc qq<';
2677 0           $left_e++;
2678             }
2679             elsif ($char[$i] eq '\Q') {
2680 0           $char[$i] = '@{[CORE::quotemeta qq<';
2681 0           $left_e++;
2682             }
2683             elsif ($char[$i] eq '\E') {
2684 0 0         if ($right_e < $left_e) {
2685 0           $char[$i] = '>]}';
2686 0           $right_e++;
2687             }
2688             else {
2689 0           $char[$i] = '';
2690             }
2691             }
2692             elsif ($char[$i] eq '\Q') {
2693 0           while (1) {
2694 0 0         if (++$i > $#char) {
2695 0           last;
2696             }
2697 0 0         if ($char[$i] eq '\E') {
2698 0           last;
2699             }
2700             }
2701             }
2702             elsif ($char[$i] eq '\E') {
2703             }
2704              
2705             # $0 --> $0
2706             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
2707             }
2708             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
2709             }
2710              
2711             # $$ --> $$
2712             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
2713             }
2714              
2715             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
2716             # $1, $2, $3 --> $1, $2, $3 otherwise
2717             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
2718 0           $char[$i] = e_capture($1);
2719             }
2720             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
2721 0           $char[$i] = e_capture($1);
2722             }
2723              
2724             # $$foo[ ... ] --> $ $foo->[ ... ]
2725             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
2726 0           $char[$i] = e_capture($1.'->'.$2);
2727             }
2728              
2729             # $$foo{ ... } --> $ $foo->{ ... }
2730             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
2731 0           $char[$i] = e_capture($1.'->'.$2);
2732             }
2733              
2734             # $$foo
2735             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
2736 0           $char[$i] = e_capture($1);
2737             }
2738              
2739             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
2740             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
2741 0           $char[$i] = '@{[Char::Eusascii::PREMATCH()]}';
2742             }
2743              
2744             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
2745             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
2746 0           $char[$i] = '@{[Char::Eusascii::MATCH()]}';
2747             }
2748              
2749             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
2750             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
2751 0           $char[$i] = '@{[Char::Eusascii::POSTMATCH()]}';
2752             }
2753              
2754             # ${ foo } --> ${ foo }
2755             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
2756             }
2757              
2758             # ${ ... }
2759             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
2760 0           $char[$i] = e_capture($1);
2761             }
2762             }
2763              
2764             # return string
2765 0 0         if ($left_e > $right_e) {
2766 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
2767             }
2768 0           return join '', $ope, $delimiter, @char, $end_delimiter;
2769             }
2770              
2771             #
2772             # escape qw string (qw//)
2773             #
2774             sub e_qw {
2775 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
2776              
2777 0           $slash = 'div';
2778              
2779             # choice again delimiter
2780 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
2781 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
2782 0           return join '', $ope, $delimiter, $string, $end_delimiter;
2783             }
2784             elsif (not $octet{')'}) {
2785 0           return join '', $ope, '(', $string, ')';
2786             }
2787             elsif (not $octet{'}'}) {
2788 0           return join '', $ope, '{', $string, '}';
2789             }
2790             elsif (not $octet{']'}) {
2791 0           return join '', $ope, '[', $string, ']';
2792             }
2793             elsif (not $octet{'>'}) {
2794 0           return join '', $ope, '<', $string, '>';
2795             }
2796             else {
2797 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
2798 0 0         if (not $octet{$char}) {
2799 0           return join '', $ope, $char, $string, $char;
2800             }
2801             }
2802             }
2803              
2804             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
2805 0           my @string = CORE::split(/\s+/, $string);
2806 0           for my $string (@string) {
2807 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
2808 0           for my $octet (@octet) {
2809 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
2810 0           $octet = '\\' . $1;
2811             }
2812             }
2813 0           $string = join '', @octet;
2814             }
2815 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
2816             }
2817              
2818             #
2819             # escape here document (<<"HEREDOC", <
2820             #
2821             sub e_heredoc {
2822 0     0 0   my($string) = @_;
2823              
2824 0           $slash = 'm//';
2825              
2826 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
2827              
2828 0           my $left_e = 0;
2829 0           my $right_e = 0;
2830 0           my @char = $string =~ /\G(
2831             \\o\{ [0-7]+ \} |
2832             \\x\{ [0-9A-Fa-f]+ \} |
2833             \\N\{ [^0-9\}][^\}]* \} |
2834             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
2835             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
2836             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
2837             \$ \s* \d+ |
2838             \$ \s* \{ \s* \d+ \s* \} |
2839             \$ \$ (?![\w\{]) |
2840             \$ \s* \$ \s* $qq_variable |
2841             \\?(?:$q_char)
2842             )/oxmsg;
2843              
2844 0           for (my $i=0; $i <= $#char; $i++) {
2845              
2846             # "\L\u" --> "\u\L"
2847 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
2848 0           @char[$i,$i+1] = @char[$i+1,$i];
2849             }
2850              
2851             # "\U\l" --> "\l\U"
2852             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
2853 0           @char[$i,$i+1] = @char[$i+1,$i];
2854             }
2855              
2856             # octal escape sequence
2857             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
2858 0           $char[$i] = Char::Eusascii::octchr($1);
2859             }
2860              
2861             # hexadecimal escape sequence
2862             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
2863 0           $char[$i] = Char::Eusascii::hexchr($1);
2864             }
2865              
2866             # \N{CHARNAME} --> N{CHARNAME}
2867             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
2868 0           $char[$i] = $1;
2869             }
2870              
2871 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
2872             }
2873              
2874             # \u \l \U \L \F \Q \E
2875 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
2876 0 0         if ($right_e < $left_e) {
2877 0           $char[$i] = '\\' . $char[$i];
2878             }
2879             }
2880             elsif ($char[$i] eq '\u') {
2881 0           $char[$i] = '@{[Char::Eusascii::ucfirst qq<';
2882 0           $left_e++;
2883             }
2884             elsif ($char[$i] eq '\l') {
2885 0           $char[$i] = '@{[Char::Eusascii::lcfirst qq<';
2886 0           $left_e++;
2887             }
2888             elsif ($char[$i] eq '\U') {
2889 0           $char[$i] = '@{[Char::Eusascii::uc qq<';
2890 0           $left_e++;
2891             }
2892             elsif ($char[$i] eq '\L') {
2893 0           $char[$i] = '@{[Char::Eusascii::lc qq<';
2894 0           $left_e++;
2895             }
2896             elsif ($char[$i] eq '\F') {
2897 0           $char[$i] = '@{[Char::Eusascii::fc qq<';
2898 0           $left_e++;
2899             }
2900             elsif ($char[$i] eq '\Q') {
2901 0           $char[$i] = '@{[CORE::quotemeta qq<';
2902 0           $left_e++;
2903             }
2904             elsif ($char[$i] eq '\E') {
2905 0 0         if ($right_e < $left_e) {
2906 0           $char[$i] = '>]}';
2907 0           $right_e++;
2908             }
2909             else {
2910 0           $char[$i] = '';
2911             }
2912             }
2913             elsif ($char[$i] eq '\Q') {
2914 0           while (1) {
2915 0 0         if (++$i > $#char) {
2916 0           last;
2917             }
2918 0 0         if ($char[$i] eq '\E') {
2919 0           last;
2920             }
2921             }
2922             }
2923             elsif ($char[$i] eq '\E') {
2924             }
2925              
2926             # $0 --> $0
2927             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
2928             }
2929             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
2930             }
2931              
2932             # $$ --> $$
2933             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
2934             }
2935              
2936             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
2937             # $1, $2, $3 --> $1, $2, $3 otherwise
2938             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
2939 0           $char[$i] = e_capture($1);
2940             }
2941             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
2942 0           $char[$i] = e_capture($1);
2943             }
2944              
2945             # $$foo[ ... ] --> $ $foo->[ ... ]
2946             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
2947 0           $char[$i] = e_capture($1.'->'.$2);
2948             }
2949              
2950             # $$foo{ ... } --> $ $foo->{ ... }
2951             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
2952 0           $char[$i] = e_capture($1.'->'.$2);
2953             }
2954              
2955             # $$foo
2956             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
2957 0           $char[$i] = e_capture($1);
2958             }
2959              
2960             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
2961             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
2962 0           $char[$i] = '@{[Char::Eusascii::PREMATCH()]}';
2963             }
2964              
2965             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
2966             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
2967 0           $char[$i] = '@{[Char::Eusascii::MATCH()]}';
2968             }
2969              
2970             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
2971             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
2972 0           $char[$i] = '@{[Char::Eusascii::POSTMATCH()]}';
2973             }
2974              
2975             # ${ foo } --> ${ foo }
2976             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
2977             }
2978              
2979             # ${ ... }
2980             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
2981 0           $char[$i] = e_capture($1);
2982             }
2983             }
2984              
2985             # return string
2986 0 0         if ($left_e > $right_e) {
2987 0           return join '', @char, '>]}' x ($left_e - $right_e);
2988             }
2989 0           return join '', @char;
2990             }
2991              
2992             #
2993             # escape regexp (m//, qr//)
2994             #
2995             sub e_qr {
2996 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
2997 0   0       $modifier ||= '';
2998              
2999 0           $modifier =~ tr/p//d;
3000 0 0         if ($modifier =~ /([adlu])/oxms) {
3001 0           my $line = 0;
3002 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
3003 0 0         if ($filename ne __FILE__) {
3004 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
3005 0           last;
3006             }
3007             }
3008 0           die qq{Unsupported modifier "$1" used at line $line.\n};
3009             }
3010              
3011 0           $slash = 'div';
3012              
3013             # literal null string pattern
3014 0 0         if ($string eq '') {
    0          
3015 0           $modifier =~ tr/bB//d;
3016 0           $modifier =~ tr/i//d;
3017 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
3018             }
3019              
3020             # /b /B modifier
3021             elsif ($modifier =~ tr/bB//d) {
3022              
3023             # choice again delimiter
3024 0 0         if ($delimiter =~ / [\@:] /oxms) {
3025 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
3026 0           my %octet = map {$_ => 1} @char;
  0            
3027 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
3028 0           $delimiter = '(';
3029 0           $end_delimiter = ')';
3030             }
3031             elsif (not $octet{'}'}) {
3032 0           $delimiter = '{';
3033 0           $end_delimiter = '}';
3034             }
3035             elsif (not $octet{']'}) {
3036 0           $delimiter = '[';
3037 0           $end_delimiter = ']';
3038             }
3039             elsif (not $octet{'>'}) {
3040 0           $delimiter = '<';
3041 0           $end_delimiter = '>';
3042             }
3043             else {
3044 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
3045 0 0         if (not $octet{$char}) {
3046 0           $delimiter = $char;
3047 0           $end_delimiter = $char;
3048 0           last;
3049             }
3050             }
3051             }
3052             }
3053              
3054 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
3055 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
3056             }
3057             else {
3058 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
3059             }
3060             }
3061              
3062 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
3063 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
3064              
3065             # split regexp
3066 0           my @char = $string =~ /\G(
3067             \\o\{ [0-7]+ \} |
3068             \\ [0-7]{2,3} |
3069             \\x\{ [0-9A-Fa-f]+ \} |
3070             \\x [0-9A-Fa-f]{1,2} |
3071             \\c [\x40-\x5F] |
3072             \\N\{ [^0-9\}][^\}]* \} |
3073             \\p\{ [^0-9\}][^\}]* \} |
3074             \\P\{ [^0-9\}][^\}]* \} |
3075             \\ (?:$q_char) |
3076             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
3077             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
3078             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
3079             [\$\@] $qq_variable |
3080             \$ \s* \d+ |
3081             \$ \s* \{ \s* \d+ \s* \} |
3082             \$ \$ (?![\w\{]) |
3083             \$ \s* \$ \s* $qq_variable |
3084             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
3085             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
3086             \[\^ |
3087             \(\? |
3088             (?:$q_char)
3089             )/oxmsg;
3090              
3091             # choice again delimiter
3092 0 0         if ($delimiter =~ / [\@:] /oxms) {
3093 0           my %octet = map {$_ => 1} @char;
  0            
3094 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
3095 0           $delimiter = '(';
3096 0           $end_delimiter = ')';
3097             }
3098             elsif (not $octet{'}'}) {
3099 0           $delimiter = '{';
3100 0           $end_delimiter = '}';
3101             }
3102             elsif (not $octet{']'}) {
3103 0           $delimiter = '[';
3104 0           $end_delimiter = ']';
3105             }
3106             elsif (not $octet{'>'}) {
3107 0           $delimiter = '<';
3108 0           $end_delimiter = '>';
3109             }
3110             else {
3111 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
3112 0 0         if (not $octet{$char}) {
3113 0           $delimiter = $char;
3114 0           $end_delimiter = $char;
3115 0           last;
3116             }
3117             }
3118             }
3119             }
3120              
3121 0           my $left_e = 0;
3122 0           my $right_e = 0;
3123 0           for (my $i=0; $i <= $#char; $i++) {
3124              
3125             # "\L\u" --> "\u\L"
3126 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
3127 0           @char[$i,$i+1] = @char[$i+1,$i];
3128             }
3129              
3130             # "\U\l" --> "\l\U"
3131             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
3132 0           @char[$i,$i+1] = @char[$i+1,$i];
3133             }
3134              
3135             # octal escape sequence
3136             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
3137 0           $char[$i] = Char::Eusascii::octchr($1);
3138             }
3139              
3140             # hexadecimal escape sequence
3141             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
3142 0           $char[$i] = Char::Eusascii::hexchr($1);
3143             }
3144              
3145             # \N{CHARNAME} --> N\{CHARNAME}
3146             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
3147 0           $char[$i] = $1 . '\\' . $2;
3148             }
3149              
3150             # \p{PROPERTY} --> p\{PROPERTY}
3151             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
3152 0           $char[$i] = $1 . '\\' . $2;
3153             }
3154              
3155             # \P{PROPERTY} --> P\{PROPERTY}
3156             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
3157 0           $char[$i] = $1 . '\\' . $2;
3158             }
3159              
3160             # \p, \P, \X --> p, P, X
3161             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
3162 0           $char[$i] = $1;
3163             }
3164              
3165 0 0 0       if (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          
3166             }
3167              
3168             # join separated multiple-octet
3169 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
3170 0 0 0       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 (eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
3171 0           $char[$i] .= join '', splice @char, $i+1, 3;
3172             }
3173             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 (eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
3174 0           $char[$i] .= join '', splice @char, $i+1, 2;
3175             }
3176             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 (eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
3177 0           $char[$i] .= join '', splice @char, $i+1, 1;
3178             }
3179             }
3180              
3181             # open character class [...]
3182             elsif ($char[$i] eq '[') {
3183 0           my $left = $i;
3184              
3185             # [] make die "Unmatched [] in regexp ..."
3186             # (and so on)
3187              
3188 0 0         if ($char[$i+1] eq ']') {
3189 0           $i++;
3190             }
3191              
3192 0           while (1) {
3193 0 0         if (++$i > $#char) {
3194 0           die __FILE__, ": Unmatched [] in regexp";
3195             }
3196 0 0         if ($char[$i] eq ']') {
3197 0           my $right = $i;
3198              
3199             # [...]
3200 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
3201 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
3202             }
3203             else {
3204 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
3205             }
3206              
3207 0           $i = $left;
3208 0           last;
3209             }
3210             }
3211             }
3212              
3213             # open character class [^...]
3214             elsif ($char[$i] eq '[^') {
3215 0           my $left = $i;
3216              
3217             # [^] make die "Unmatched [] in regexp ..."
3218             # (and so on)
3219              
3220 0 0         if ($char[$i+1] eq ']') {
3221 0           $i++;
3222             }
3223              
3224 0           while (1) {
3225 0 0         if (++$i > $#char) {
3226 0           die __FILE__, ": Unmatched [] in regexp";
3227             }
3228 0 0         if ($char[$i] eq ']') {
3229 0           my $right = $i;
3230              
3231             # [^...]
3232 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
3233 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
3234             }
3235             else {
3236 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
3237             }
3238              
3239 0           $i = $left;
3240 0           last;
3241             }
3242             }
3243             }
3244              
3245             # rewrite character class or escape character
3246             elsif (my $char = character_class($char[$i],$modifier)) {
3247 0           $char[$i] = $char;
3248             }
3249              
3250             # /i modifier
3251             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
3252 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
3253 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
3254             }
3255             else {
3256 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
3257             }
3258             }
3259              
3260             # \u \l \U \L \F \Q \E
3261             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
3262 0 0         if ($right_e < $left_e) {
3263 0           $char[$i] = '\\' . $char[$i];
3264             }
3265             }
3266             elsif ($char[$i] eq '\u') {
3267 0           $char[$i] = '@{[Char::Eusascii::ucfirst qq<';
3268 0           $left_e++;
3269             }
3270             elsif ($char[$i] eq '\l') {
3271 0           $char[$i] = '@{[Char::Eusascii::lcfirst qq<';
3272 0           $left_e++;
3273             }
3274             elsif ($char[$i] eq '\U') {
3275 0           $char[$i] = '@{[Char::Eusascii::uc qq<';
3276 0           $left_e++;
3277             }
3278             elsif ($char[$i] eq '\L') {
3279 0           $char[$i] = '@{[Char::Eusascii::lc qq<';
3280 0           $left_e++;
3281             }
3282             elsif ($char[$i] eq '\F') {
3283 0           $char[$i] = '@{[Char::Eusascii::fc qq<';
3284 0           $left_e++;
3285             }
3286             elsif ($char[$i] eq '\Q') {
3287 0           $char[$i] = '@{[CORE::quotemeta qq<';
3288 0           $left_e++;
3289             }
3290             elsif ($char[$i] eq '\E') {
3291 0 0         if ($right_e < $left_e) {
3292 0           $char[$i] = '>]}';
3293 0           $right_e++;
3294             }
3295             else {
3296 0           $char[$i] = '';
3297             }
3298             }
3299             elsif ($char[$i] eq '\Q') {
3300 0           while (1) {
3301 0 0         if (++$i > $#char) {
3302 0           last;
3303             }
3304 0 0         if ($char[$i] eq '\E') {
3305 0           last;
3306             }
3307             }
3308             }
3309             elsif ($char[$i] eq '\E') {
3310             }
3311              
3312             # $0 --> $0
3313             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
3314 0 0         if ($ignorecase) {
3315 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
3316             }
3317             }
3318             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
3319 0 0         if ($ignorecase) {
3320 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
3321             }
3322             }
3323              
3324             # $$ --> $$
3325             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
3326             }
3327              
3328             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3329             # $1, $2, $3 --> $1, $2, $3 otherwise
3330             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
3331 0           $char[$i] = e_capture($1);
3332 0 0         if ($ignorecase) {
3333 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
3334             }
3335             }
3336             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
3337 0           $char[$i] = e_capture($1);
3338 0 0         if ($ignorecase) {
3339 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
3340             }
3341             }
3342              
3343             # $$foo[ ... ] --> $ $foo->[ ... ]
3344             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
3345 0           $char[$i] = e_capture($1.'->'.$2);
3346 0 0         if ($ignorecase) {
3347 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
3348             }
3349             }
3350              
3351             # $$foo{ ... } --> $ $foo->{ ... }
3352             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
3353 0           $char[$i] = e_capture($1.'->'.$2);
3354 0 0         if ($ignorecase) {
3355 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
3356             }
3357             }
3358              
3359             # $$foo
3360             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
3361 0           $char[$i] = e_capture($1);
3362 0 0         if ($ignorecase) {
3363 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
3364             }
3365             }
3366              
3367             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
3368             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
3369 0 0         if ($ignorecase) {
3370 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::PREMATCH())]}';
3371             }
3372             else {
3373 0           $char[$i] = '@{[Char::Eusascii::PREMATCH()]}';
3374             }
3375             }
3376              
3377             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
3378             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
3379 0 0         if ($ignorecase) {
3380 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::MATCH())]}';
3381             }
3382             else {
3383 0           $char[$i] = '@{[Char::Eusascii::MATCH()]}';
3384             }
3385             }
3386              
3387             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
3388             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
3389 0 0         if ($ignorecase) {
3390 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::POSTMATCH())]}';
3391             }
3392             else {
3393 0           $char[$i] = '@{[Char::Eusascii::POSTMATCH()]}';
3394             }
3395             }
3396              
3397             # ${ foo }
3398             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
3399 0 0         if ($ignorecase) {
3400 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
3401             }
3402             }
3403              
3404             # ${ ... }
3405             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
3406 0           $char[$i] = e_capture($1);
3407 0 0         if ($ignorecase) {
3408 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
3409             }
3410             }
3411              
3412             # $scalar or @array
3413             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
3414 0           $char[$i] = e_string($char[$i]);
3415 0 0         if ($ignorecase) {
3416 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
3417             }
3418             }
3419              
3420             # quote character before ? + * {
3421             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
3422 0 0 0       if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
3423             }
3424             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
3425 0           my $char = $char[$i-1];
3426 0 0         if ($char[$i] eq '{') {
3427 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}};
3428             }
3429             else {
3430 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]};
3431             }
3432             }
3433             else {
3434 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
3435             }
3436             }
3437             }
3438              
3439             # make regexp string
3440 0           $modifier =~ tr/i//d;
3441 0 0         if ($left_e > $right_e) {
3442 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
3443 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
3444             }
3445             else {
3446 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
3447             }
3448             }
3449 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
3450 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
3451             }
3452             else {
3453 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
3454             }
3455             }
3456              
3457             #
3458             # double quote stuff
3459             #
3460             sub qq_stuff {
3461 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
3462              
3463             # scalar variable or array variable
3464 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
3465 0           return $stuff;
3466             }
3467              
3468             # quote by delimiter
3469 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
3470 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
3471 0 0         next if $char eq $delimiter;
3472 0 0         next if $char eq $end_delimiter;
3473 0 0         if (not $octet{$char}) {
3474 0           return join '', 'qq', $char, $stuff, $char;
3475             }
3476             }
3477 0           return join '', 'qq', '<', $stuff, '>';
3478             }
3479              
3480             #
3481             # escape regexp (m'', qr'', and m''b, qr''b)
3482             #
3483             sub e_qr_q {
3484 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
3485 0   0       $modifier ||= '';
3486              
3487 0           $modifier =~ tr/p//d;
3488 0 0         if ($modifier =~ /([adlu])/oxms) {
3489 0           my $line = 0;
3490 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
3491 0 0         if ($filename ne __FILE__) {
3492 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
3493 0           last;
3494             }
3495             }
3496 0           die qq{Unsupported modifier "$1" used at line $line.\n};
3497             }
3498              
3499 0           $slash = 'div';
3500              
3501             # literal null string pattern
3502 0 0         if ($string eq '') {
    0          
3503 0           $modifier =~ tr/bB//d;
3504 0           $modifier =~ tr/i//d;
3505 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
3506             }
3507              
3508             # with /b /B modifier
3509             elsif ($modifier =~ tr/bB//d) {
3510 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
3511             }
3512              
3513             # without /b /B modifier
3514             else {
3515 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
3516             }
3517             }
3518              
3519             #
3520             # escape regexp (m'', qr'')
3521             #
3522             sub e_qr_qt {
3523 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
3524              
3525 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
3526              
3527             # split regexp
3528 0           my @char = $string =~ /\G(
3529             \[\:\^ [a-z]+ \:\] |
3530             \[\: [a-z]+ \:\] |
3531             \[\^ |
3532             [\$\@\/\\] |
3533             \\? (?:$q_char)
3534             )/oxmsg;
3535              
3536             # unescape character
3537 0           for (my $i=0; $i <= $#char; $i++) {
3538 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
3539             }
3540              
3541             # open character class [...]
3542 0           elsif ($char[$i] eq '[') {
3543 0           my $left = $i;
3544 0 0         if ($char[$i+1] eq ']') {
3545 0           $i++;
3546             }
3547 0           while (1) {
3548 0 0         if (++$i > $#char) {
3549 0           die __FILE__, ": Unmatched [] in regexp";
3550             }
3551 0 0         if ($char[$i] eq ']') {
3552 0           my $right = $i;
3553              
3554             # [...]
3555 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
3556              
3557 0           $i = $left;
3558 0           last;
3559             }
3560             }
3561             }
3562              
3563             # open character class [^...]
3564             elsif ($char[$i] eq '[^') {
3565 0           my $left = $i;
3566 0 0         if ($char[$i+1] eq ']') {
3567 0           $i++;
3568             }
3569 0           while (1) {
3570 0 0         if (++$i > $#char) {
3571 0           die __FILE__, ": Unmatched [] in regexp";
3572             }
3573 0 0         if ($char[$i] eq ']') {
3574 0           my $right = $i;
3575              
3576             # [^...]
3577 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
3578              
3579 0           $i = $left;
3580 0           last;
3581             }
3582             }
3583             }
3584              
3585             # escape $ @ / and \
3586             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
3587 0           $char[$i] = '\\' . $char[$i];
3588             }
3589              
3590             # rewrite character class or escape character
3591             elsif (my $char = character_class($char[$i],$modifier)) {
3592 0           $char[$i] = $char;
3593             }
3594              
3595             # /i modifier
3596             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
3597 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
3598 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
3599             }
3600             else {
3601 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
3602             }
3603             }
3604              
3605             # quote character before ? + * {
3606             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
3607 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
3608             }
3609             else {
3610 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
3611             }
3612             }
3613             }
3614              
3615 0           $delimiter = '/';
3616 0           $end_delimiter = '/';
3617              
3618 0           $modifier =~ tr/i//d;
3619 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
3620             }
3621              
3622             #
3623             # escape regexp (m''b, qr''b)
3624             #
3625             sub e_qr_qb {
3626 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
3627              
3628             # split regexp
3629 0           my @char = $string =~ /\G(
3630             \\\\ |
3631             [\$\@\/\\] |
3632             [\x00-\xFF]
3633             )/oxmsg;
3634              
3635             # unescape character
3636 0           for (my $i=0; $i <= $#char; $i++) {
3637 0 0         if (0) {
    0          
3638             }
3639              
3640             # remain \\
3641 0           elsif ($char[$i] eq '\\\\') {
3642             }
3643              
3644             # escape $ @ / and \
3645             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
3646 0           $char[$i] = '\\' . $char[$i];
3647             }
3648             }
3649              
3650 0           $delimiter = '/';
3651 0           $end_delimiter = '/';
3652 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
3653             }
3654              
3655             #
3656             # escape regexp (s/here//)
3657             #
3658             sub e_s1 {
3659 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
3660 0   0       $modifier ||= '';
3661              
3662 0           $modifier =~ tr/p//d;
3663 0 0         if ($modifier =~ /([adlu])/oxms) {
3664 0           my $line = 0;
3665 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
3666 0 0         if ($filename ne __FILE__) {
3667 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
3668 0           last;
3669             }
3670             }
3671 0           die qq{Unsupported modifier "$1" used at line $line.\n};
3672             }
3673              
3674 0           $slash = 'div';
3675              
3676             # literal null string pattern
3677 0 0         if ($string eq '') {
    0          
3678 0           $modifier =~ tr/bB//d;
3679 0           $modifier =~ tr/i//d;
3680 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
3681             }
3682              
3683             # /b /B modifier
3684             elsif ($modifier =~ tr/bB//d) {
3685              
3686             # choice again delimiter
3687 0 0         if ($delimiter =~ / [\@:] /oxms) {
3688 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
3689 0           my %octet = map {$_ => 1} @char;
  0            
3690 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
3691 0           $delimiter = '(';
3692 0           $end_delimiter = ')';
3693             }
3694             elsif (not $octet{'}'}) {
3695 0           $delimiter = '{';
3696 0           $end_delimiter = '}';
3697             }
3698             elsif (not $octet{']'}) {
3699 0           $delimiter = '[';
3700 0           $end_delimiter = ']';
3701             }
3702             elsif (not $octet{'>'}) {
3703 0           $delimiter = '<';
3704 0           $end_delimiter = '>';
3705             }
3706             else {
3707 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
3708 0 0         if (not $octet{$char}) {
3709 0           $delimiter = $char;
3710 0           $end_delimiter = $char;
3711 0           last;
3712             }
3713             }
3714             }
3715             }
3716              
3717 0           my $prematch = '';
3718 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
3719             }
3720              
3721 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
3722 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
3723              
3724             # split regexp
3725 0           my @char = $string =~ /\G(
3726             \\g \s* \{ \s* - \s* [1-9][0-9]* \s* \} |
3727             \\g \s* \{ \s* [1-9][0-9]* \s* \} |
3728             \\g \s* [1-9][0-9]* |
3729             \\o\{ [0-7]+ \} |
3730             \\ [1-9][0-9]* |
3731             \\ [0-7]{2,3} |
3732             \\x\{ [0-9A-Fa-f]+ \} |
3733             \\x [0-9A-Fa-f]{1,2} |
3734             \\c [\x40-\x5F] |
3735             \\N\{ [^0-9\}][^\}]* \} |
3736             \\p\{ [^0-9\}][^\}]* \} |
3737             \\P\{ [^0-9\}][^\}]* \} |
3738             \\ (?:$q_char) |
3739             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
3740             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
3741             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
3742             [\$\@] $qq_variable |
3743             \$ \s* \d+ |
3744             \$ \s* \{ \s* \d+ \s* \} |
3745             \$ \$ (?![\w\{]) |
3746             \$ \s* \$ \s* $qq_variable |
3747             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
3748             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
3749             \[\^ |
3750             \(\? |
3751             (?:$q_char)
3752             )/oxmsg;
3753              
3754             # choice again delimiter
3755 0 0         if ($delimiter =~ / [\@:] /oxms) {
3756 0           my %octet = map {$_ => 1} @char;
  0            
3757 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
3758 0           $delimiter = '(';
3759 0           $end_delimiter = ')';
3760             }
3761             elsif (not $octet{'}'}) {
3762 0           $delimiter = '{';
3763 0           $end_delimiter = '}';
3764             }
3765             elsif (not $octet{']'}) {
3766 0           $delimiter = '[';
3767 0           $end_delimiter = ']';
3768             }
3769             elsif (not $octet{'>'}) {
3770 0           $delimiter = '<';
3771 0           $end_delimiter = '>';
3772             }
3773             else {
3774 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
3775 0 0         if (not $octet{$char}) {
3776 0           $delimiter = $char;
3777 0           $end_delimiter = $char;
3778 0           last;
3779             }
3780             }
3781             }
3782             }
3783              
3784             # count '('
3785 0           my $parens = grep { $_ eq '(' } @char;
  0            
3786              
3787 0           my $left_e = 0;
3788 0           my $right_e = 0;
3789 0           for (my $i=0; $i <= $#char; $i++) {
3790              
3791             # "\L\u" --> "\u\L"
3792 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
3793 0           @char[$i,$i+1] = @char[$i+1,$i];
3794             }
3795              
3796             # "\U\l" --> "\l\U"
3797             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
3798 0           @char[$i,$i+1] = @char[$i+1,$i];
3799             }
3800              
3801             # octal escape sequence
3802             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
3803 0           $char[$i] = Char::Eusascii::octchr($1);
3804             }
3805              
3806             # hexadecimal escape sequence
3807             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
3808 0           $char[$i] = Char::Eusascii::hexchr($1);
3809             }
3810              
3811             # \N{CHARNAME} --> N\{CHARNAME}
3812             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
3813 0           $char[$i] = $1 . '\\' . $2;
3814             }
3815              
3816             # \p{PROPERTY} --> p\{PROPERTY}
3817             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
3818 0           $char[$i] = $1 . '\\' . $2;
3819             }
3820              
3821             # \P{PROPERTY} --> P\{PROPERTY}
3822             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
3823 0           $char[$i] = $1 . '\\' . $2;
3824             }
3825              
3826             # \p, \P, \X --> p, P, X
3827             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
3828 0           $char[$i] = $1;
3829             }
3830              
3831 0 0 0       if (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          
3832             }
3833              
3834             # join separated multiple-octet
3835 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
3836 0 0 0       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 (eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
3837 0           $char[$i] .= join '', splice @char, $i+1, 3;
3838             }
3839             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 (eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
3840 0           $char[$i] .= join '', splice @char, $i+1, 2;
3841             }
3842             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 (eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
3843 0           $char[$i] .= join '', splice @char, $i+1, 1;
3844             }
3845             }
3846              
3847             # open character class [...]
3848             elsif ($char[$i] eq '[') {
3849 0           my $left = $i;
3850 0 0         if ($char[$i+1] eq ']') {
3851 0           $i++;
3852             }
3853 0           while (1) {
3854 0 0         if (++$i > $#char) {
3855 0           die __FILE__, ": Unmatched [] in regexp";
3856             }
3857 0 0         if ($char[$i] eq ']') {
3858 0           my $right = $i;
3859              
3860             # [...]
3861 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
3862 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
3863             }
3864             else {
3865 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
3866             }
3867              
3868 0           $i = $left;
3869 0           last;
3870             }
3871             }
3872             }
3873              
3874             # open character class [^...]
3875             elsif ($char[$i] eq '[^') {
3876 0           my $left = $i;
3877 0 0         if ($char[$i+1] eq ']') {
3878 0           $i++;
3879             }
3880 0           while (1) {
3881 0 0         if (++$i > $#char) {
3882 0           die __FILE__, ": Unmatched [] in regexp";
3883             }
3884 0 0         if ($char[$i] eq ']') {
3885 0           my $right = $i;
3886              
3887             # [^...]
3888 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
3889 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
3890             }
3891             else {
3892 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
3893             }
3894              
3895 0           $i = $left;
3896 0           last;
3897             }
3898             }
3899             }
3900              
3901             # rewrite character class or escape character
3902             elsif (my $char = character_class($char[$i],$modifier)) {
3903 0           $char[$i] = $char;
3904             }
3905              
3906             # /i modifier
3907             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
3908 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
3909 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
3910             }
3911             else {
3912 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
3913             }
3914             }
3915              
3916             # \u \l \U \L \F \Q \E
3917             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
3918 0 0         if ($right_e < $left_e) {
3919 0           $char[$i] = '\\' . $char[$i];
3920             }
3921             }
3922             elsif ($char[$i] eq '\u') {
3923 0           $char[$i] = '@{[Char::Eusascii::ucfirst qq<';
3924 0           $left_e++;
3925             }
3926             elsif ($char[$i] eq '\l') {
3927 0           $char[$i] = '@{[Char::Eusascii::lcfirst qq<';
3928 0           $left_e++;
3929             }
3930             elsif ($char[$i] eq '\U') {
3931 0           $char[$i] = '@{[Char::Eusascii::uc qq<';
3932 0           $left_e++;
3933             }
3934             elsif ($char[$i] eq '\L') {
3935 0           $char[$i] = '@{[Char::Eusascii::lc qq<';
3936 0           $left_e++;
3937             }
3938             elsif ($char[$i] eq '\F') {
3939 0           $char[$i] = '@{[Char::Eusascii::fc qq<';
3940 0           $left_e++;
3941             }
3942             elsif ($char[$i] eq '\Q') {
3943 0           $char[$i] = '@{[CORE::quotemeta qq<';
3944 0           $left_e++;
3945             }
3946             elsif ($char[$i] eq '\E') {
3947 0 0         if ($right_e < $left_e) {
3948 0           $char[$i] = '>]}';
3949 0           $right_e++;
3950             }
3951             else {
3952 0           $char[$i] = '';
3953             }
3954             }
3955             elsif ($char[$i] eq '\Q') {
3956 0           while (1) {
3957 0 0         if (++$i > $#char) {
3958 0           last;
3959             }
3960 0 0         if ($char[$i] eq '\E') {
3961 0           last;
3962             }
3963             }
3964             }
3965             elsif ($char[$i] eq '\E') {
3966             }
3967              
3968             # \0 --> \0
3969             elsif ($char[$i] =~ /\A \\ \s* 0 \z/oxms) {
3970             }
3971              
3972             # \g{N}, \g{-N}
3973              
3974             # P.108 Using Simple Patterns
3975             # in Chapter 7: In the World of Regular Expressions
3976             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3977              
3978             # P.221 Capturing
3979             # in Chapter 5: Pattern Matching
3980             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3981              
3982             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
3983             elsif ($char[$i] =~ /\A \\g \s* \{ \s* - \s* ([1-9][0-9]*) \s* \} \z/oxms) {
3984             }
3985              
3986             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
3987             elsif ($char[$i] =~ /\A \\g \s* \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
3988             }
3989              
3990             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
3991             elsif ($char[$i] =~ /\A \\g \s* ([1-9][0-9]*) \z/oxms) {
3992             }
3993              
3994             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
3995             elsif ($char[$i] =~ /\A \\ \s* ([1-9][0-9]*) \z/oxms) {
3996             }
3997              
3998             # $0 --> $0
3999             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
4000 0 0         if ($ignorecase) {
4001 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4002             }
4003             }
4004             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
4005 0 0         if ($ignorecase) {
4006 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4007             }
4008             }
4009              
4010             # $$ --> $$
4011             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
4012             }
4013              
4014             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4015             # $1, $2, $3 --> $1, $2, $3 otherwise
4016             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
4017 0           $char[$i] = e_capture($1);
4018 0 0         if ($ignorecase) {
4019 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4020             }
4021             }
4022             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
4023 0           $char[$i] = e_capture($1);
4024 0 0         if ($ignorecase) {
4025 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4026             }
4027             }
4028              
4029             # $$foo[ ... ] --> $ $foo->[ ... ]
4030             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
4031 0           $char[$i] = e_capture($1.'->'.$2);
4032 0 0         if ($ignorecase) {
4033 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4034             }
4035             }
4036              
4037             # $$foo{ ... } --> $ $foo->{ ... }
4038             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
4039 0           $char[$i] = e_capture($1.'->'.$2);
4040 0 0         if ($ignorecase) {
4041 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4042             }
4043             }
4044              
4045             # $$foo
4046             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
4047 0           $char[$i] = e_capture($1);
4048 0 0         if ($ignorecase) {
4049 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4050             }
4051             }
4052              
4053             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
4054             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
4055 0 0         if ($ignorecase) {
4056 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::PREMATCH())]}';
4057             }
4058             else {
4059 0           $char[$i] = '@{[Char::Eusascii::PREMATCH()]}';
4060             }
4061             }
4062              
4063             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
4064             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
4065 0 0         if ($ignorecase) {
4066 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::MATCH())]}';
4067             }
4068             else {
4069 0           $char[$i] = '@{[Char::Eusascii::MATCH()]}';
4070             }
4071             }
4072              
4073             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
4074             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
4075 0 0         if ($ignorecase) {
4076 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::POSTMATCH())]}';
4077             }
4078             else {
4079 0           $char[$i] = '@{[Char::Eusascii::POSTMATCH()]}';
4080             }
4081             }
4082              
4083             # ${ foo }
4084             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
4085 0 0         if ($ignorecase) {
4086 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4087             }
4088             }
4089              
4090             # ${ ... }
4091             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
4092 0           $char[$i] = e_capture($1);
4093 0 0         if ($ignorecase) {
4094 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4095             }
4096             }
4097              
4098             # $scalar or @array
4099             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
4100 0           $char[$i] = e_string($char[$i]);
4101 0 0         if ($ignorecase) {
4102 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4103             }
4104             }
4105              
4106             # quote character before ? + * {
4107             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
4108 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
4109             }
4110             else {
4111 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
4112             }
4113             }
4114             }
4115              
4116             # make regexp string
4117 0           my $prematch = '';
4118 0           $modifier =~ tr/i//d;
4119 0 0         if ($left_e > $right_e) {
4120 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
4121             }
4122 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
4123             }
4124              
4125             #
4126             # escape regexp (s'here'' or s'here''b)
4127             #
4128             sub e_s1_q {
4129 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
4130 0   0       $modifier ||= '';
4131              
4132 0           $modifier =~ tr/p//d;
4133 0 0         if ($modifier =~ /([adlu])/oxms) {
4134 0           my $line = 0;
4135 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
4136 0 0         if ($filename ne __FILE__) {
4137 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
4138 0           last;
4139             }
4140             }
4141 0           die qq{Unsupported modifier "$1" used at line $line.\n};
4142             }
4143              
4144 0           $slash = 'div';
4145              
4146             # literal null string pattern
4147 0 0         if ($string eq '') {
    0          
4148 0           $modifier =~ tr/bB//d;
4149 0           $modifier =~ tr/i//d;
4150 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
4151             }
4152              
4153             # with /b /B modifier
4154             elsif ($modifier =~ tr/bB//d) {
4155 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
4156             }
4157              
4158             # without /b /B modifier
4159             else {
4160 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
4161             }
4162             }
4163              
4164             #
4165             # escape regexp (s'here'')
4166             #
4167             sub e_s1_qt {
4168 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
4169              
4170 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
4171              
4172             # split regexp
4173 0           my @char = $string =~ /\G(
4174             \[\:\^ [a-z]+ \:\] |
4175             \[\: [a-z]+ \:\] |
4176             \[\^ |
4177             [\$\@\/\\] |
4178             \\? (?:$q_char)
4179             )/oxmsg;
4180              
4181             # unescape character
4182 0           for (my $i=0; $i <= $#char; $i++) {
4183 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
4184             }
4185              
4186             # open character class [...]
4187 0           elsif ($char[$i] eq '[') {
4188 0           my $left = $i;
4189 0 0         if ($char[$i+1] eq ']') {
4190 0           $i++;
4191             }
4192 0           while (1) {
4193 0 0         if (++$i > $#char) {
4194 0           die __FILE__, ": Unmatched [] in regexp";
4195             }
4196 0 0         if ($char[$i] eq ']') {
4197 0           my $right = $i;
4198              
4199             # [...]
4200 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
4201              
4202 0           $i = $left;
4203 0           last;
4204             }
4205             }
4206             }
4207              
4208             # open character class [^...]
4209             elsif ($char[$i] eq '[^') {
4210 0           my $left = $i;
4211 0 0         if ($char[$i+1] eq ']') {
4212 0           $i++;
4213             }
4214 0           while (1) {
4215 0 0         if (++$i > $#char) {
4216 0           die __FILE__, ": Unmatched [] in regexp";
4217             }
4218 0 0         if ($char[$i] eq ']') {
4219 0           my $right = $i;
4220              
4221             # [^...]
4222 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
4223              
4224 0           $i = $left;
4225 0           last;
4226             }
4227             }
4228             }
4229              
4230             # escape $ @ / and \
4231             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
4232 0           $char[$i] = '\\' . $char[$i];
4233             }
4234              
4235             # rewrite character class or escape character
4236             elsif (my $char = character_class($char[$i],$modifier)) {
4237 0           $char[$i] = $char;
4238             }
4239              
4240             # /i modifier
4241             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
4242 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
4243 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
4244             }
4245             else {
4246 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
4247             }
4248             }
4249              
4250             # quote character before ? + * {
4251             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
4252 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
4253             }
4254             else {
4255 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
4256             }
4257             }
4258             }
4259              
4260 0           $modifier =~ tr/i//d;
4261 0           $delimiter = '/';
4262 0           $end_delimiter = '/';
4263 0           my $prematch = '';
4264 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
4265             }
4266              
4267             #
4268             # escape regexp (s'here''b)
4269             #
4270             sub e_s1_qb {
4271 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
4272              
4273             # split regexp
4274 0           my @char = $string =~ /\G(
4275             \\\\ |
4276             [\$\@\/\\] |
4277             [\x00-\xFF]
4278             )/oxmsg;
4279              
4280             # unescape character
4281 0           for (my $i=0; $i <= $#char; $i++) {
4282 0 0         if (0) {
    0          
4283             }
4284              
4285             # remain \\
4286 0           elsif ($char[$i] eq '\\\\') {
4287             }
4288              
4289             # escape $ @ / and \
4290             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
4291 0           $char[$i] = '\\' . $char[$i];
4292             }
4293             }
4294              
4295 0           $delimiter = '/';
4296 0           $end_delimiter = '/';
4297 0           my $prematch = '';
4298 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
4299             }
4300              
4301             #
4302             # escape regexp (s''here')
4303             #
4304             sub e_s2_q {
4305 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
4306              
4307 0           $slash = 'div';
4308              
4309 0           my @char = $string =~ / \G (\\\\|[\$\@\/\\]|$q_char) /oxmsg;
4310 0           for (my $i=0; $i <= $#char; $i++) {
4311 0 0         if (0) {
    0          
4312             }
4313              
4314             # not escape \\
4315 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
4316             }
4317              
4318             # escape $ @ / and \
4319             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
4320 0           $char[$i] = '\\' . $char[$i];
4321             }
4322             }
4323              
4324 0           return join '', $ope, $delimiter, @char, $end_delimiter;
4325             }
4326              
4327             #
4328             # escape regexp (s/here/and here/modifier)
4329             #
4330             sub e_sub {
4331 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
4332 0   0       $modifier ||= '';
4333              
4334 0           $modifier =~ tr/p//d;
4335 0 0         if ($modifier =~ /([adlu])/oxms) {
4336 0           my $line = 0;
4337 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
4338 0 0         if ($filename ne __FILE__) {
4339 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
4340 0           last;
4341             }
4342             }
4343 0           die qq{Unsupported modifier "$1" used at line $line.\n};
4344             }
4345              
4346 0 0         if ($variable eq '') {
4347 0           $variable = '$_';
4348 0           $bind_operator = ' =~ ';
4349             }
4350              
4351 0           $slash = 'div';
4352              
4353             # P.128 Start of match (or end of previous match): \G
4354             # P.130 Advanced Use of \G with Perl
4355             # in Chapter 3: Overview of Regular Expression Features and Flavors
4356             # P.312 Iterative Matching: Scalar Context, with /g
4357             # in Chapter 7: Perl
4358             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
4359              
4360             # P.181 Where You Left Off: The \G Assertion
4361             # in Chapter 5: Pattern Matching
4362             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4363              
4364             # P.220 Where You Left Off: The \G Assertion
4365             # in Chapter 5: Pattern Matching
4366             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4367              
4368 0           my $e_modifier = $modifier =~ tr/e//d;
4369 0           my $r_modifier = $modifier =~ tr/r//d;
4370              
4371 0           my $my = '';
4372 0 0         if ($variable =~ s/\A \( \s* ( (?: local \b | my \b | our \b | state \b )? .+ ) \) \z/$1/oxms) {
4373 0           $my = $variable;
4374 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) \s* //oxms;
4375 0           $variable =~ s/ = .+ \z//oxms;
4376             }
4377              
4378 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
4379 0           $variable_basename =~ s/ \s+ \z//oxms;
4380              
4381             # quote replacement string
4382 0           my $e_replacement = '';
4383 0 0         if ($e_modifier >= 1) {
4384 0           $e_replacement = e_qq('', '', '', $replacement);
4385 0           $e_modifier--;
4386             }
4387             else {
4388 0 0         if ($delimiter2 eq "'") {
4389 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
4390             }
4391             else {
4392 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
4393             }
4394             }
4395              
4396 0           my $sub = '';
4397              
4398             # with /r
4399 0 0         if ($r_modifier) {
4400 0 0         if (0) {
4401             }
4402              
4403             # s///gr without multibyte anchoring
4404 0           elsif ($modifier =~ /g/oxms) {
4405 0 0         $sub = sprintf(
4406             # 1 2 3 4 5
4407             q,
4408              
4409             $variable, # 1
4410             ($delimiter1 eq "'") ? # 2
4411             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
4412             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
4413             $s_matched, # 3
4414             $e_replacement, # 4
4415             '$Char::USASCII::re_r=eval $Char::USASCII::re_r; ' x $e_modifier, # 5
4416             );
4417             }
4418              
4419             # s///r
4420             else {
4421              
4422 0           my $prematch = q{$`};
4423              
4424 0 0         $sub = sprintf(
4425             # 1 2 3 4 5 6 7
4426             q<(%s =~ %s) ? eval{%s local $^W=0; local $Char::USASCII::re_r=%s; %s"%s$Char::USASCII::re_r$'" } : %s>,
4427              
4428             $variable, # 1
4429             ($delimiter1 eq "'") ? # 2
4430             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
4431             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
4432             $s_matched, # 3
4433             $e_replacement, # 4
4434             '$Char::USASCII::re_r=eval $Char::USASCII::re_r; ' x $e_modifier, # 5
4435             $prematch, # 6
4436             $variable, # 7
4437             );
4438             }
4439              
4440             # $var !~ s///r doesn't make sense
4441 0 0         if ($bind_operator =~ / !~ /oxms) {
4442 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
4443             }
4444             }
4445              
4446             # without /r
4447             else {
4448 0 0         if (0) {
4449             }
4450              
4451             # s///g without multibyte anchoring
4452 0           elsif ($modifier =~ /g/oxms) {
4453 0 0         $sub = sprintf(
    0          
4454             # 1 2 3 4 5 6 7 8
4455             q,
4456              
4457             $variable, # 1
4458             ($delimiter1 eq "'") ? # 2
4459             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
4460             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
4461             $s_matched, # 3
4462             $e_replacement, # 4
4463             '$Char::USASCII::re_r=eval $Char::USASCII::re_r; ' x $e_modifier, # 5
4464             $variable, # 6
4465             $variable, # 7
4466             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
4467             );
4468             }
4469              
4470             # s///
4471             else {
4472              
4473 0           my $prematch = q{$`};
4474              
4475 0 0         $sub = sprintf(
    0          
4476              
4477             ($bind_operator =~ / =~ /oxms) ?
4478              
4479             # 1 2 3 4 5 6 7 8
4480             q<(%s%s%s) ? eval{%s local $^W=0; local $Char::USASCII::re_r=%s; %s%s="%s$Char::USASCII::re_r$'"; 1 } : undef> :
4481              
4482             # 1 2 3 4 5 6 7 8
4483             q<(%s%s%s) ? 1 : eval{%s local $^W=0; local $Char::USASCII::re_r=%s; %s%s="%s$Char::USASCII::re_r$'"; undef }>,
4484              
4485             $variable, # 1
4486             $bind_operator, # 2
4487             ($delimiter1 eq "'") ? # 3
4488             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
4489             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
4490             $s_matched, # 4
4491             $e_replacement, # 5
4492             '$Char::USASCII::re_r=eval $Char::USASCII::re_r; ' x $e_modifier, # 6
4493             $variable, # 7
4494             $prematch, # 8
4495             );
4496             }
4497             }
4498              
4499             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, eval { ... })[1]
4500 0 0         if ($my ne '') {
4501 0           $sub = "($my, $sub)[1]";
4502             }
4503              
4504             # clear s/// variable
4505 0           $sub_variable = '';
4506 0           $bind_operator = '';
4507              
4508 0           return $sub;
4509             }
4510              
4511             #
4512             # escape regexp of split qr//
4513             #
4514             sub e_split {
4515 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
4516 0   0       $modifier ||= '';
4517              
4518 0           $modifier =~ tr/p//d;
4519 0 0         if ($modifier =~ /([adlu])/oxms) {
4520 0           my $line = 0;
4521 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
4522 0 0         if ($filename ne __FILE__) {
4523 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
4524 0           last;
4525             }
4526             }
4527 0           die qq{Unsupported modifier "$1" used at line $line.\n};
4528             }
4529              
4530 0           $slash = 'div';
4531              
4532             # /b /B modifier
4533 0 0         if ($modifier =~ tr/bB//d) {
4534 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
4535             }
4536              
4537 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
4538 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
4539              
4540             # split regexp
4541 0           my @char = $string =~ /\G(
4542             \\o\{ [0-7]+ \} |
4543             \\ [0-7]{2,3} |
4544             \\x\{ [0-9A-Fa-f]+ \} |
4545             \\x [0-9A-Fa-f]{1,2} |
4546             \\c [\x40-\x5F] |
4547             \\N\{ [^0-9\}][^\}]* \} |
4548             \\p\{ [^0-9\}][^\}]* \} |
4549             \\P\{ [^0-9\}][^\}]* \} |
4550             \\ (?:$q_char) |
4551             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
4552             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
4553             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
4554             [\$\@] $qq_variable |
4555             \$ \s* \d+ |
4556             \$ \s* \{ \s* \d+ \s* \} |
4557             \$ \$ (?![\w\{]) |
4558             \$ \s* \$ \s* $qq_variable |
4559             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
4560             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
4561             \[\^ |
4562             \(\? |
4563             (?:$q_char)
4564             )/oxmsg;
4565              
4566 0           my $left_e = 0;
4567 0           my $right_e = 0;
4568 0           for (my $i=0; $i <= $#char; $i++) {
4569              
4570             # "\L\u" --> "\u\L"
4571 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
4572 0           @char[$i,$i+1] = @char[$i+1,$i];
4573             }
4574              
4575             # "\U\l" --> "\l\U"
4576             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
4577 0           @char[$i,$i+1] = @char[$i+1,$i];
4578             }
4579              
4580             # octal escape sequence
4581             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
4582 0           $char[$i] = Char::Eusascii::octchr($1);
4583             }
4584              
4585             # hexadecimal escape sequence
4586             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
4587 0           $char[$i] = Char::Eusascii::hexchr($1);
4588             }
4589              
4590             # \N{CHARNAME} --> N\{CHARNAME}
4591             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
4592 0           $char[$i] = $1 . '\\' . $2;
4593             }
4594              
4595             # \p{PROPERTY} --> p\{PROPERTY}
4596             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
4597 0           $char[$i] = $1 . '\\' . $2;
4598             }
4599              
4600             # \P{PROPERTY} --> P\{PROPERTY}
4601             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
4602 0           $char[$i] = $1 . '\\' . $2;
4603             }
4604              
4605             # \p, \P, \X --> p, P, X
4606             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
4607 0           $char[$i] = $1;
4608             }
4609              
4610 0 0 0       if (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          
4611             }
4612              
4613             # join separated multiple-octet
4614 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
4615 0 0 0       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 (eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
4616 0           $char[$i] .= join '', splice @char, $i+1, 3;
4617             }
4618             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 (eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
4619 0           $char[$i] .= join '', splice @char, $i+1, 2;
4620             }
4621             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 (eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
4622 0           $char[$i] .= join '', splice @char, $i+1, 1;
4623             }
4624             }
4625              
4626             # open character class [...]
4627             elsif ($char[$i] eq '[') {
4628 0           my $left = $i;
4629 0 0         if ($char[$i+1] eq ']') {
4630 0           $i++;
4631             }
4632 0           while (1) {
4633 0 0         if (++$i > $#char) {
4634 0           die __FILE__, ": Unmatched [] in regexp";
4635             }
4636 0 0         if ($char[$i] eq ']') {
4637 0           my $right = $i;
4638              
4639             # [...]
4640 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
4641 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
4642             }
4643             else {
4644 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
4645             }
4646              
4647 0           $i = $left;
4648 0           last;
4649             }
4650             }
4651             }
4652              
4653             # open character class [^...]
4654             elsif ($char[$i] eq '[^') {
4655 0           my $left = $i;
4656 0 0         if ($char[$i+1] eq ']') {
4657 0           $i++;
4658             }
4659 0           while (1) {
4660 0 0         if (++$i > $#char) {
4661 0           die __FILE__, ": Unmatched [] in regexp";
4662             }
4663 0 0         if ($char[$i] eq ']') {
4664 0           my $right = $i;
4665              
4666             # [^...]
4667 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
4668 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
4669             }
4670             else {
4671 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
4672             }
4673              
4674 0           $i = $left;
4675 0           last;
4676             }
4677             }
4678             }
4679              
4680             # rewrite character class or escape character
4681             elsif (my $char = character_class($char[$i],$modifier)) {
4682 0           $char[$i] = $char;
4683             }
4684              
4685             # P.794 29.2.161. split
4686             # in Chapter 29: Functions
4687             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4688              
4689             # P.951 split
4690             # in Chapter 27: Functions
4691             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4692              
4693             # said "The //m modifier is assumed when you split on the pattern /^/",
4694             # but perl5.008 is not so. Therefore, this software adds //m.
4695             # (and so on)
4696              
4697             # split(m/^/) --> split(m/^/m)
4698             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
4699 0           $modifier .= 'm';
4700             }
4701              
4702             # /i modifier
4703             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
4704 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
4705 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
4706             }
4707             else {
4708 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
4709             }
4710             }
4711              
4712             # \u \l \U \L \F \Q \E
4713             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
4714 0 0         if ($right_e < $left_e) {
4715 0           $char[$i] = '\\' . $char[$i];
4716             }
4717             }
4718             elsif ($char[$i] eq '\u') {
4719 0           $char[$i] = '@{[Char::Eusascii::ucfirst qq<';
4720 0           $left_e++;
4721             }
4722             elsif ($char[$i] eq '\l') {
4723 0           $char[$i] = '@{[Char::Eusascii::lcfirst qq<';
4724 0           $left_e++;
4725             }
4726             elsif ($char[$i] eq '\U') {
4727 0           $char[$i] = '@{[Char::Eusascii::uc qq<';
4728 0           $left_e++;
4729             }
4730             elsif ($char[$i] eq '\L') {
4731 0           $char[$i] = '@{[Char::Eusascii::lc qq<';
4732 0           $left_e++;
4733             }
4734             elsif ($char[$i] eq '\F') {
4735 0           $char[$i] = '@{[Char::Eusascii::fc qq<';
4736 0           $left_e++;
4737             }
4738             elsif ($char[$i] eq '\Q') {
4739 0           $char[$i] = '@{[CORE::quotemeta qq<';
4740 0           $left_e++;
4741             }
4742             elsif ($char[$i] eq '\E') {
4743 0 0         if ($right_e < $left_e) {
4744 0           $char[$i] = '>]}';
4745 0           $right_e++;
4746             }
4747             else {
4748 0           $char[$i] = '';
4749             }
4750             }
4751             elsif ($char[$i] eq '\Q') {
4752 0           while (1) {
4753 0 0         if (++$i > $#char) {
4754 0           last;
4755             }
4756 0 0         if ($char[$i] eq '\E') {
4757 0           last;
4758             }
4759             }
4760             }
4761             elsif ($char[$i] eq '\E') {
4762             }
4763              
4764             # $0 --> $0
4765             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
4766 0 0         if ($ignorecase) {
4767 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4768             }
4769             }
4770             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
4771 0 0         if ($ignorecase) {
4772 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4773             }
4774             }
4775              
4776             # $$ --> $$
4777             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
4778             }
4779              
4780             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4781             # $1, $2, $3 --> $1, $2, $3 otherwise
4782             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
4783 0           $char[$i] = e_capture($1);
4784 0 0         if ($ignorecase) {
4785 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4786             }
4787             }
4788             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
4789 0           $char[$i] = e_capture($1);
4790 0 0         if ($ignorecase) {
4791 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4792             }
4793             }
4794              
4795             # $$foo[ ... ] --> $ $foo->[ ... ]
4796             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
4797 0           $char[$i] = e_capture($1.'->'.$2);
4798 0 0         if ($ignorecase) {
4799 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4800             }
4801             }
4802              
4803             # $$foo{ ... } --> $ $foo->{ ... }
4804             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
4805 0           $char[$i] = e_capture($1.'->'.$2);
4806 0 0         if ($ignorecase) {
4807 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4808             }
4809             }
4810              
4811             # $$foo
4812             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
4813 0           $char[$i] = e_capture($1);
4814 0 0         if ($ignorecase) {
4815 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4816             }
4817             }
4818              
4819             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
4820             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
4821 0 0         if ($ignorecase) {
4822 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::PREMATCH())]}';
4823             }
4824             else {
4825 0           $char[$i] = '@{[Char::Eusascii::PREMATCH()]}';
4826             }
4827             }
4828              
4829             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
4830             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
4831 0 0         if ($ignorecase) {
4832 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::MATCH())]}';
4833             }
4834             else {
4835 0           $char[$i] = '@{[Char::Eusascii::MATCH()]}';
4836             }
4837             }
4838              
4839             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
4840             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
4841 0 0         if ($ignorecase) {
4842 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::POSTMATCH())]}';
4843             }
4844             else {
4845 0           $char[$i] = '@{[Char::Eusascii::POSTMATCH()]}';
4846             }
4847             }
4848              
4849             # ${ foo }
4850             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
4851 0 0         if ($ignorecase) {
4852 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $1 . ')]}';
4853             }
4854             }
4855              
4856             # ${ ... }
4857             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
4858 0           $char[$i] = e_capture($1);
4859 0 0         if ($ignorecase) {
4860 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4861             }
4862             }
4863              
4864             # $scalar or @array
4865             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
4866 0           $char[$i] = e_string($char[$i]);
4867 0 0         if ($ignorecase) {
4868 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
4869             }
4870             }
4871              
4872             # quote character before ? + * {
4873             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
4874 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
4875             }
4876             else {
4877 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
4878             }
4879             }
4880             }
4881              
4882             # make regexp string
4883 0           $modifier =~ tr/i//d;
4884 0 0         if ($left_e > $right_e) {
4885 0           return join '', 'Char::Eusascii::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
4886             }
4887 0           return join '', 'Char::Eusascii::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
4888             }
4889              
4890             #
4891             # escape regexp of split qr''
4892             #
4893             sub e_split_q {
4894 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
4895 0   0       $modifier ||= '';
4896              
4897 0           $modifier =~ tr/p//d;
4898 0 0         if ($modifier =~ /([adlu])/oxms) {
4899 0           my $line = 0;
4900 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
4901 0 0         if ($filename ne __FILE__) {
4902 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
4903 0           last;
4904             }
4905             }
4906 0           die qq{Unsupported modifier "$1" used at line $line.\n};
4907             }
4908              
4909 0           $slash = 'div';
4910              
4911             # /b /B modifier
4912 0 0         if ($modifier =~ tr/bB//d) {
4913 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
4914             }
4915              
4916 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
4917              
4918             # split regexp
4919 0           my @char = $string =~ /\G(
4920             \[\:\^ [a-z]+ \:\] |
4921             \[\: [a-z]+ \:\] |
4922             \[\^ |
4923             \\? (?:$q_char)
4924             )/oxmsg;
4925              
4926             # unescape character
4927 0           for (my $i=0; $i <= $#char; $i++) {
4928 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
4929             }
4930              
4931             # open character class [...]
4932 0           elsif ($char[$i] eq '[') {
4933 0           my $left = $i;
4934 0 0         if ($char[$i+1] eq ']') {
4935 0           $i++;
4936             }
4937 0           while (1) {
4938 0 0         if (++$i > $#char) {
4939 0           die __FILE__, ": Unmatched [] in regexp";
4940             }
4941 0 0         if ($char[$i] eq ']') {
4942 0           my $right = $i;
4943              
4944             # [...]
4945 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
4946              
4947 0           $i = $left;
4948 0           last;
4949             }
4950             }
4951             }
4952              
4953             # open character class [^...]
4954             elsif ($char[$i] eq '[^') {
4955 0           my $left = $i;
4956 0 0         if ($char[$i+1] eq ']') {
4957 0           $i++;
4958             }
4959 0           while (1) {
4960 0 0         if (++$i > $#char) {
4961 0           die __FILE__, ": Unmatched [] in regexp";
4962             }
4963 0 0         if ($char[$i] eq ']') {
4964 0           my $right = $i;
4965              
4966             # [^...]
4967 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
4968              
4969 0           $i = $left;
4970 0           last;
4971             }
4972             }
4973             }
4974              
4975             # rewrite character class or escape character
4976             elsif (my $char = character_class($char[$i],$modifier)) {
4977 0           $char[$i] = $char;
4978             }
4979              
4980             # split(m/^/) --> split(m/^/m)
4981             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
4982 0           $modifier .= 'm';
4983             }
4984              
4985             # /i modifier
4986             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
4987 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
4988 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
4989             }
4990             else {
4991 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
4992             }
4993             }
4994              
4995             # quote character before ? + * {
4996             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
4997 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
4998             }
4999             else {
5000 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5001             }
5002             }
5003             }
5004              
5005 0           $modifier =~ tr/i//d;
5006 0           return join '', 'Char::Eusascii::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
5007             }
5008              
5009             1;
5010              
5011             __END__