File Coverage

Char/Greek.pm
Criterion Covered Total %
statement 49 2194 2.2
branch 11 2162 0.5
condition 1 199 0.5
subroutine 14 40 35.0
pod 0 25 0.0
total 75 4620 1.6


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