File Coverage

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


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