File Coverage

Char/Eusascii.pm
Criterion Covered Total %
statement 83 3062 2.7
branch 4 2670 0.1
condition 1 373 0.2
subroutine 36 125 28.8
pod 7 74 9.4
total 131 6304 2.0


line stmt bran cond sub pod time code
1             #
2             # This file is *** FOR CPAN USE ONLY ***.
3             #
4             package Char::Eusascii;
5             ######################################################################
6             #
7             # Char::Eusascii - Run-time routines for Char/USASCII.pm
8             #
9             # http://search.cpan.org/dist/Char-USASCII/
10             #
11             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
12             ######################################################################
13              
14 197     197   7866 use 5.00503; # Galapagos Consensus 1998 for primetools
  197         640  
  197         19087  
15             # use 5.008001; # Lancaster Consensus 2013 for toolchains
16              
17             # 12.3. Delaying use Until Runtime
18             # in Chapter 12. Packages, Libraries, and Modules
19             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
20             # (and so on)
21              
22 197     197   19408 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  197     197   1260  
  197         348  
  197         46052  
23             $VERSION = sprintf '%d.%02d', q$Revision: 1.02 $ =~ /(\d+)/xmsg;
24              
25             BEGIN {
26 197 50   197   1529 if ($^X =~ / jperl /oxmsi) {
27 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)";
28             }
29 197         295 if (CORE::ord('A') == 193) {
30             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).";
31             }
32 197         36415 if (CORE::ord('A') != 0x41) {
33             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).";
34             }
35             }
36              
37             BEGIN {
38              
39             # instead of utf8.pm
40 197     197   21067 CORE::eval q{
  197     197   1188  
  197     78   409  
  197         29106  
  78         13947  
  53         8337  
  73         11672  
  68         13961  
  64         10963  
  58         10309  
41             no warnings qw(redefine);
42             *utf8::upgrade = sub { CORE::length $_[0] };
43             *utf8::downgrade = sub { 1 };
44             *utf8::encode = sub { };
45             *utf8::decode = sub { 1 };
46             *utf8::is_utf8 = sub { };
47             *utf8::valid = sub { 1 };
48             };
49 197 50       121465 if ($@) {
50 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
51 0         0 *utf8::downgrade = sub { 1 };
  0         0  
52 0         0 *utf8::encode = sub { };
  0         0  
53 0         0 *utf8::decode = sub { 1 };
  0         0  
54 0         0 *utf8::is_utf8 = sub { };
  0         0  
55 0         0 *utf8::valid = sub { 1 };
  0         0  
56             }
57             }
58              
59             # instead of Symbol.pm
60             BEGIN {
61 197     197   516 my $genpkg = "Symbol::";
62 197         10438 my $genseq = 0;
63              
64             sub gensym () {
65 0     0 0 0 my $name = "GEN" . $genseq++;
66              
67             # here, no strict qw(refs); if strict.pm exists
68              
69 0         0 my $ref = \*{$genpkg . $name};
  0         0  
70 0         0 delete $$genpkg{$name};
71 0         0 return $ref;
72             }
73              
74             sub qualify ($;$) {
75 0     0 0 0 my ($name) = @_;
76 0 0 0     0 if (!ref($name) && (Char::Eusascii::index($name, '::') == -1) && (Char::Eusascii::index($name, "'") == -1)) {
      0        
77 0         0 my $pkg;
78 0         0 my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT DATA);
  0         0  
79              
80             # Global names: special character, "^xyz", or other.
81 0 0 0     0 if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
82             # RGS 2001-11-05 : translate leading ^X to control-char
83 0         0 $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  0         0  
84 0         0 $pkg = "main";
85             }
86             else {
87 0 0       0 $pkg = (@_ > 1) ? $_[1] : caller;
88             }
89 0         0 $name = $pkg . "::" . $name;
90             }
91 0         0 return $name;
92             }
93              
94             sub qualify_to_ref ($;$) {
95              
96             # here, no strict qw(refs); if strict.pm exists
97              
98 0 0   0 0 0 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  0         0  
99             }
100             }
101              
102             # Column: local $@
103             # in Chapter 9. Osaete okitai Perl no kiso
104             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
105             # (and so on)
106              
107             # use strict; if strict.pm exists
108             BEGIN {
109 197 50   197   455 if (CORE::eval { local $@; CORE::require strict }) {
  197         369  
  197         2425  
110 197         26932 strict::->import;
111             }
112             }
113              
114             # P.714 29.2.39. flock
115             # in Chapter 29: Functions
116             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
117              
118             # P.863 flock
119             # in Chapter 27: Functions
120             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
121              
122             sub LOCK_SH() {1}
123             sub LOCK_EX() {2}
124             sub LOCK_UN() {8}
125             sub LOCK_NB() {4}
126              
127             # instead of Carp.pm
128             sub carp;
129             sub croak;
130             sub cluck;
131             sub confess;
132              
133             # 6.18. Matching Multiple-Byte Characters
134             # in Chapter 6. Pattern Matching
135             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
136             # (and so on)
137              
138             # regexp of character
139 197     197   13216 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  197     197   2041  
  197         339  
  197         12581  
140 197     197   12468 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  197     197   1075  
  197         293  
  197         15234  
141 197     197   12089 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  197     197   1058  
  197         322  
  197         16523  
142              
143             #
144             # US-ASCII character range per length
145             #
146             my %range_tr = ();
147              
148             #
149             # alias of encoding name
150             #
151 197     197   12319 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  197     197   1567  
  197         328  
  197         171468  
152              
153             #
154             # US-ASCII case conversion
155             #
156             my %lc = ();
157             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
158             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
159             my %uc = ();
160             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
161             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
162             my %fc = ();
163             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
164             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
165              
166             if (0) {
167             }
168              
169             elsif (__PACKAGE__ =~ / \b Eusascii \z/oxms) {
170             %range_tr = (
171             1 => [ [0x00..0xFF],
172             ],
173             );
174             $encoding_alias = qr/ \b (?: (?:us-?)?ascii ) \b /oxmsi;
175             }
176              
177             else {
178             croak "Don't know my package name '@{[__PACKAGE__]}'";
179             }
180              
181             #
182             # @ARGV wildcard globbing
183             #
184             sub import {
185              
186 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
187 0         0 my @argv = ();
188 0         0 for (@ARGV) {
189              
190             # has space
191 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
192 0 0       0 if (my @glob = Char::Eusascii::glob(qq{"$_"})) {
193 0         0 push @argv, @glob;
194             }
195             else {
196 0         0 push @argv, $_;
197             }
198             }
199              
200             # has wildcard metachar
201             elsif (/\A (?:$q_char)*? [*?] /oxms) {
202 0 0       0 if (my @glob = Char::Eusascii::glob($_)) {
203 0         0 push @argv, @glob;
204             }
205             else {
206 0         0 push @argv, $_;
207             }
208             }
209              
210             # no wildcard globbing
211             else {
212 0         0 push @argv, $_;
213             }
214             }
215 0         0 @ARGV = @argv;
216             }
217             }
218              
219             # P.230 Care with Prototypes
220             # in Chapter 6: Subroutines
221             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
222             #
223             # If you aren't careful, you can get yourself into trouble with prototypes.
224             # But if you are careful, you can do a lot of neat things with them. This is
225             # all very powerful, of course, and should only be used in moderation to make
226             # the world a better place.
227              
228             # P.332 Care with Prototypes
229             # in Chapter 7: Subroutines
230             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
231             #
232             # If you aren't careful, you can get yourself into trouble with prototypes.
233             # But if you are careful, you can do a lot of neat things with them. This is
234             # all very powerful, of course, and should only be used in moderation to make
235             # the world a better place.
236              
237             #
238             # Prototypes of subroutines
239             #
240 0     0   0 sub unimport {}
241             sub Char::Eusascii::split(;$$$);
242             sub Char::Eusascii::tr($$$$;$);
243             sub Char::Eusascii::chop(@);
244             sub Char::Eusascii::index($$;$);
245             sub Char::Eusascii::rindex($$;$);
246             sub Char::Eusascii::lcfirst(@);
247             sub Char::Eusascii::lcfirst_();
248             sub Char::Eusascii::lc(@);
249             sub Char::Eusascii::lc_();
250             sub Char::Eusascii::ucfirst(@);
251             sub Char::Eusascii::ucfirst_();
252             sub Char::Eusascii::uc(@);
253             sub Char::Eusascii::uc_();
254             sub Char::Eusascii::fc(@);
255             sub Char::Eusascii::fc_();
256             sub Char::Eusascii::ignorecase;
257             sub Char::Eusascii::classic_character_class;
258             sub Char::Eusascii::capture;
259             sub Char::Eusascii::chr(;$);
260             sub Char::Eusascii::chr_();
261             sub Char::Eusascii::glob($);
262             sub Char::Eusascii::glob_();
263              
264             sub Char::USASCII::ord(;$);
265             sub Char::USASCII::ord_();
266             sub Char::USASCII::reverse(@);
267             sub Char::USASCII::getc(;*@);
268             sub Char::USASCII::length(;$);
269             sub Char::USASCII::substr($$;$$);
270             sub Char::USASCII::index($$;$);
271             sub Char::USASCII::rindex($$;$);
272             sub Char::USASCII::escape(;$);
273              
274             #
275             # Regexp work
276             #
277 197     197   16879 BEGIN { CORE::eval q{ use vars qw(
  197     197   1319  
  197         340  
  197         98478  
278             $Char::USASCII::re_a
279             $Char::USASCII::re_t
280             $Char::USASCII::re_n
281             $Char::USASCII::re_r
282             ) } }
283              
284             #
285             # Character class
286             #
287 197     197   19586 BEGIN { CORE::eval q{ use vars qw(
  197     197   1400  
  197         361  
  197         3140908  
288             $dot
289             $dot_s
290             $eD
291             $eS
292             $eW
293             $eH
294             $eV
295             $eR
296             $eN
297             $not_alnum
298             $not_alpha
299             $not_ascii
300             $not_blank
301             $not_cntrl
302             $not_digit
303             $not_graph
304             $not_lower
305             $not_lower_i
306             $not_print
307             $not_punct
308             $not_space
309             $not_upper
310             $not_upper_i
311             $not_word
312             $not_xdigit
313             $eb
314             $eB
315             ) } }
316              
317             ${Char::Eusascii::dot} = qr{(?:[^\x0A])};
318             ${Char::Eusascii::dot_s} = qr{(?:[\x00-\xFF])};
319             ${Char::Eusascii::eD} = qr{(?:[^0-9])};
320              
321             # Vertical tabs are now whitespace
322             # \s in a regex now matches a vertical tab in all circumstances.
323             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
324             # ${Char::Eusascii::eS} = qr{(?:[^\x09\x0A \x0C\x0D\x20])};
325             # ${Char::Eusascii::eS} = qr{(?:[^\x09\x0A\x0B\x0C\x0D\x20])};
326             ${Char::Eusascii::eS} = qr{(?:[^\s])};
327              
328             ${Char::Eusascii::eW} = qr{(?:[^0-9A-Z_a-z])};
329             ${Char::Eusascii::eH} = qr{(?:[^\x09\x20])};
330             ${Char::Eusascii::eV} = qr{(?:[^\x0A\x0B\x0C\x0D])};
331             ${Char::Eusascii::eR} = qr{(?:\x0D\x0A|[\x0A\x0D])};
332             ${Char::Eusascii::eN} = qr{(?:[^\x0A])};
333             ${Char::Eusascii::not_alnum} = qr{(?:[^\x30-\x39\x41-\x5A\x61-\x7A])};
334             ${Char::Eusascii::not_alpha} = qr{(?:[^\x41-\x5A\x61-\x7A])};
335             ${Char::Eusascii::not_ascii} = qr{(?:[^\x00-\x7F])};
336             ${Char::Eusascii::not_blank} = qr{(?:[^\x09\x20])};
337             ${Char::Eusascii::not_cntrl} = qr{(?:[^\x00-\x1F\x7F])};
338             ${Char::Eusascii::not_digit} = qr{(?:[^\x30-\x39])};
339             ${Char::Eusascii::not_graph} = qr{(?:[^\x21-\x7F])};
340             ${Char::Eusascii::not_lower} = qr{(?:[^\x61-\x7A])};
341             ${Char::Eusascii::not_lower_i} = qr{(?:[\x00-\xFF])};
342             ${Char::Eusascii::not_print} = qr{(?:[^\x20-\x7F])};
343             ${Char::Eusascii::not_punct} = qr{(?:[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
344             ${Char::Eusascii::not_space} = qr{(?:[^\s\x0B])};
345             ${Char::Eusascii::not_upper} = qr{(?:[^\x41-\x5A])};
346             ${Char::Eusascii::not_upper_i} = qr{(?:[\x00-\xFF])};
347             ${Char::Eusascii::not_word} = qr{(?:[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
348             ${Char::Eusascii::not_xdigit} = qr{(?:[^\x30-\x39\x41-\x46\x61-\x66])};
349             ${Char::Eusascii::eb} = qr{(?:\A(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[0-9A-Z_a-z])|(?<=[0-9A-Z_a-z])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]|\z))};
350             ${Char::Eusascii::eB} = qr{(?:(?<=[0-9A-Z_a-z])(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]))};
351              
352             # avoid: Name "Char::Eusascii::foo" used only once: possible typo at here.
353             ${Char::Eusascii::dot} = ${Char::Eusascii::dot};
354             ${Char::Eusascii::dot_s} = ${Char::Eusascii::dot_s};
355             ${Char::Eusascii::eD} = ${Char::Eusascii::eD};
356             ${Char::Eusascii::eS} = ${Char::Eusascii::eS};
357             ${Char::Eusascii::eW} = ${Char::Eusascii::eW};
358             ${Char::Eusascii::eH} = ${Char::Eusascii::eH};
359             ${Char::Eusascii::eV} = ${Char::Eusascii::eV};
360             ${Char::Eusascii::eR} = ${Char::Eusascii::eR};
361             ${Char::Eusascii::eN} = ${Char::Eusascii::eN};
362             ${Char::Eusascii::not_alnum} = ${Char::Eusascii::not_alnum};
363             ${Char::Eusascii::not_alpha} = ${Char::Eusascii::not_alpha};
364             ${Char::Eusascii::not_ascii} = ${Char::Eusascii::not_ascii};
365             ${Char::Eusascii::not_blank} = ${Char::Eusascii::not_blank};
366             ${Char::Eusascii::not_cntrl} = ${Char::Eusascii::not_cntrl};
367             ${Char::Eusascii::not_digit} = ${Char::Eusascii::not_digit};
368             ${Char::Eusascii::not_graph} = ${Char::Eusascii::not_graph};
369             ${Char::Eusascii::not_lower} = ${Char::Eusascii::not_lower};
370             ${Char::Eusascii::not_lower_i} = ${Char::Eusascii::not_lower_i};
371             ${Char::Eusascii::not_print} = ${Char::Eusascii::not_print};
372             ${Char::Eusascii::not_punct} = ${Char::Eusascii::not_punct};
373             ${Char::Eusascii::not_space} = ${Char::Eusascii::not_space};
374             ${Char::Eusascii::not_upper} = ${Char::Eusascii::not_upper};
375             ${Char::Eusascii::not_upper_i} = ${Char::Eusascii::not_upper_i};
376             ${Char::Eusascii::not_word} = ${Char::Eusascii::not_word};
377             ${Char::Eusascii::not_xdigit} = ${Char::Eusascii::not_xdigit};
378             ${Char::Eusascii::eb} = ${Char::Eusascii::eb};
379             ${Char::Eusascii::eB} = ${Char::Eusascii::eB};
380              
381             #
382             # US-ASCII split
383             #
384             sub Char::Eusascii::split(;$$$) {
385              
386             # P.794 29.2.161. split
387             # in Chapter 29: Functions
388             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
389              
390             # P.951 split
391             # in Chapter 27: Functions
392             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
393              
394 0     0 0 0 my $pattern = $_[0];
395 0         0 my $string = $_[1];
396 0         0 my $limit = $_[2];
397              
398             # if $pattern is also omitted or is the literal space, " "
399 0 0       0 if (not defined $pattern) {
400 0         0 $pattern = ' ';
401             }
402              
403             # if $string is omitted, the function splits the $_ string
404 0 0       0 if (not defined $string) {
405 0 0       0 if (defined $_) {
406 0         0 $string = $_;
407             }
408             else {
409 0         0 $string = '';
410             }
411             }
412              
413 0         0 my @split = ();
414              
415             # when string is empty
416 0 0       0 if ($string eq '') {
    0          
417              
418             # resulting list value in list context
419 0 0       0 if (wantarray) {
420 0         0 return @split;
421             }
422              
423             # count of substrings in scalar context
424             else {
425 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
426 0         0 @_ = @split;
427 0         0 return scalar @_;
428             }
429             }
430              
431             # split's first argument is more consistently interpreted
432             #
433             # After some changes earlier in v5.17, split's behavior has been simplified:
434             # if the PATTERN argument evaluates to a string containing one space, it is
435             # treated the way that a literal string containing one space once was.
436             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
437              
438             # if $pattern is also omitted or is the literal space, " ", the function splits
439             # on whitespace, /\s+/, after skipping any leading whitespace
440             # (and so on)
441              
442             elsif ($pattern eq ' ') {
443 0 0       0 if (not defined $limit) {
444 0         0 return CORE::split(' ', $string);
445             }
446             else {
447 0         0 return CORE::split(' ', $string, $limit);
448             }
449             }
450              
451             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
452 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
453              
454             # a pattern capable of matching either the null string or something longer than the
455             # null string will split the value of $string into separate characters wherever it
456             # matches the null string between characters
457             # (and so on)
458              
459 0 0       0 if ('' =~ / \A $pattern \z /xms) {
460 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
461 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
462              
463             # P.1024 Appendix W.10 Multibyte Processing
464             # of ISBN 1-56592-224-7 CJKV Information Processing
465             # (and so on)
466              
467             # the //m modifier is assumed when you split on the pattern /^/
468             # (and so on)
469              
470             # V
471 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
472              
473             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
474             # is included in the resulting list, interspersed with the fields that are ordinarily returned
475             # (and so on)
476              
477 0         0 local $@;
478 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
479 0         0 push @split, CORE::eval('$' . $digit);
480             }
481             }
482             }
483              
484             else {
485 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
486              
487             # V
488 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
489 0         0 local $@;
490 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
491 0         0 push @split, CORE::eval('$' . $digit);
492             }
493             }
494             }
495             }
496              
497             elsif ($limit > 0) {
498 0 0       0 if ('' =~ / \A $pattern \z /xms) {
499 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
500 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
501              
502             # V
503 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
504 0         0 local $@;
505 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
506 0         0 push @split, CORE::eval('$' . $digit);
507             }
508             }
509             }
510             }
511             else {
512 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
513 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
514              
515             # V
516 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
517 0         0 local $@;
518 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
519 0         0 push @split, CORE::eval('$' . $digit);
520             }
521             }
522             }
523             }
524             }
525              
526 0 0       0 if (CORE::length($string) > 0) {
527 0         0 push @split, $string;
528             }
529              
530             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
531 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
532 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
533 0         0 pop @split;
534             }
535             }
536              
537             # resulting list value in list context
538 0 0       0 if (wantarray) {
539 0         0 return @split;
540             }
541              
542             # count of substrings in scalar context
543             else {
544 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
545 0         0 @_ = @split;
546 0         0 return scalar @_;
547             }
548             }
549              
550             #
551             # get last subexpression offsets
552             #
553             sub _last_subexpression_offsets {
554 0     0   0 my $pattern = $_[0];
555              
556             # remove comment
557 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
558              
559 0         0 my $modifier = '';
560 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
561 0         0 $modifier = $1;
562 0         0 $modifier =~ s/-[A-Za-z]*//;
563             }
564              
565             # with /x modifier
566 0         0 my @char = ();
567 0 0       0 if ($modifier =~ /x/oxms) {
568 0         0 @char = $pattern =~ /\G(
569             \\ (?:$q_char) |
570             \# (?:$q_char)*? $ |
571             \[ (?: \\\] | (?:$q_char))+? \] |
572             \(\? |
573             (?:$q_char)
574             )/oxmsg;
575             }
576              
577             # without /x modifier
578             else {
579 0         0 @char = $pattern =~ /\G(
580             \\ (?:$q_char) |
581             \[ (?: \\\] | (?:$q_char))+? \] |
582             \(\? |
583             (?:$q_char)
584             )/oxmsg;
585             }
586              
587 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
588             }
589              
590             #
591             # US-ASCII transliteration (tr///)
592             #
593             sub Char::Eusascii::tr($$$$;$) {
594              
595 0     0 0 0 my $bind_operator = $_[1];
596 0         0 my $searchlist = $_[2];
597 0         0 my $replacementlist = $_[3];
598 0   0     0 my $modifier = $_[4] || '';
599              
600 0 0       0 if ($modifier =~ /r/oxms) {
601 0 0       0 if ($bind_operator =~ / !~ /oxms) {
602 0         0 croak "Using !~ with tr///r doesn't make sense";
603             }
604             }
605              
606 0         0 my @char = $_[0] =~ /\G ($q_char) /oxmsg;
607 0         0 my @searchlist = _charlist_tr($searchlist);
608 0         0 my @replacementlist = _charlist_tr($replacementlist);
609              
610 0         0 my %tr = ();
611 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
612 0 0       0 if (not exists $tr{$searchlist[$i]}) {
613 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
614 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
615             }
616             elsif ($modifier =~ /d/oxms) {
617 0         0 $tr{$searchlist[$i]} = '';
618             }
619             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
620 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
621             }
622             else {
623 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
624             }
625             }
626             }
627              
628 0         0 my $tr = 0;
629 0         0 my $replaced = '';
630 0 0       0 if ($modifier =~ /c/oxms) {
631 0         0 while (defined(my $char = shift @char)) {
632 0 0       0 if (not exists $tr{$char}) {
633 0 0       0 if (defined $replacementlist[0]) {
634 0         0 $replaced .= $replacementlist[0];
635             }
636 0         0 $tr++;
637 0 0       0 if ($modifier =~ /s/oxms) {
638 0   0     0 while (@char and (not exists $tr{$char[0]})) {
639 0         0 shift @char;
640 0         0 $tr++;
641             }
642             }
643             }
644             else {
645 0         0 $replaced .= $char;
646             }
647             }
648             }
649             else {
650 0         0 while (defined(my $char = shift @char)) {
651 0 0       0 if (exists $tr{$char}) {
652 0         0 $replaced .= $tr{$char};
653 0         0 $tr++;
654 0 0       0 if ($modifier =~ /s/oxms) {
655 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
656 0         0 shift @char;
657 0         0 $tr++;
658             }
659             }
660             }
661             else {
662 0         0 $replaced .= $char;
663             }
664             }
665             }
666              
667 0 0       0 if ($modifier =~ /r/oxms) {
668 0         0 return $replaced;
669             }
670             else {
671 0         0 $_[0] = $replaced;
672 0 0       0 if ($bind_operator =~ / !~ /oxms) {
673 0         0 return not $tr;
674             }
675             else {
676 0         0 return $tr;
677             }
678             }
679             }
680              
681             #
682             # US-ASCII chop
683             #
684             sub Char::Eusascii::chop(@) {
685              
686 0     0 0 0 my $chop;
687 0 0       0 if (@_ == 0) {
688 0         0 my @char = /\G ($q_char) /oxmsg;
689 0         0 $chop = pop @char;
690 0         0 $_ = join '', @char;
691             }
692             else {
693 0         0 for (@_) {
694 0         0 my @char = /\G ($q_char) /oxmsg;
695 0         0 $chop = pop @char;
696 0         0 $_ = join '', @char;
697             }
698             }
699 0         0 return $chop;
700             }
701              
702             #
703             # US-ASCII index by octet
704             #
705             sub Char::Eusascii::index($$;$) {
706              
707 0     0 1 0 my($str,$substr,$position) = @_;
708 0   0     0 $position ||= 0;
709 0         0 my $pos = 0;
710              
711 0         0 while ($pos < CORE::length($str)) {
712 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
713 0 0       0 if ($pos >= $position) {
714 0         0 return $pos;
715             }
716             }
717 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
718 0         0 $pos += CORE::length($1);
719             }
720             else {
721 0         0 $pos += 1;
722             }
723             }
724 0         0 return -1;
725             }
726              
727             #
728             # US-ASCII reverse index
729             #
730             sub Char::Eusascii::rindex($$;$) {
731              
732 0     0 0 0 my($str,$substr,$position) = @_;
733 0   0     0 $position ||= CORE::length($str) - 1;
734 0         0 my $pos = 0;
735 0         0 my $rindex = -1;
736              
737 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
738 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
739 0         0 $rindex = $pos;
740             }
741 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
742 0         0 $pos += CORE::length($1);
743             }
744             else {
745 0         0 $pos += 1;
746             }
747             }
748 0         0 return $rindex;
749             }
750              
751             #
752             # US-ASCII lower case first with parameter
753             #
754             sub Char::Eusascii::lcfirst(@) {
755 0 0   0 0 0 if (@_) {
756 0         0 my $s = shift @_;
757 0 0 0     0 if (@_ and wantarray) {
758 0         0 return Char::Eusascii::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
759             }
760             else {
761 0         0 return Char::Eusascii::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
762             }
763             }
764             else {
765 0         0 return Char::Eusascii::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
766             }
767             }
768              
769             #
770             # US-ASCII lower case first without parameter
771             #
772             sub Char::Eusascii::lcfirst_() {
773 0     0 0 0 return Char::Eusascii::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
774             }
775              
776             #
777             # US-ASCII lower case with parameter
778             #
779             sub Char::Eusascii::lc(@) {
780 0 0   0 0 0 if (@_) {
781 0         0 my $s = shift @_;
782 0 0 0     0 if (@_ and wantarray) {
783 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
784             }
785             else {
786 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
787             }
788             }
789             else {
790 0         0 return Char::Eusascii::lc_();
791             }
792             }
793              
794             #
795             # US-ASCII lower case without parameter
796             #
797             sub Char::Eusascii::lc_() {
798 0     0 0 0 my $s = $_;
799 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
800             }
801              
802             #
803             # US-ASCII upper case first with parameter
804             #
805             sub Char::Eusascii::ucfirst(@) {
806 0 0   0 0 0 if (@_) {
807 0         0 my $s = shift @_;
808 0 0 0     0 if (@_ and wantarray) {
809 0         0 return Char::Eusascii::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
810             }
811             else {
812 0         0 return Char::Eusascii::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
813             }
814             }
815             else {
816 0         0 return Char::Eusascii::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
817             }
818             }
819              
820             #
821             # US-ASCII upper case first without parameter
822             #
823             sub Char::Eusascii::ucfirst_() {
824 0     0 0 0 return Char::Eusascii::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
825             }
826              
827             #
828             # US-ASCII upper case with parameter
829             #
830             sub Char::Eusascii::uc(@) {
831 0 0   0 0 0 if (@_) {
832 0         0 my $s = shift @_;
833 0 0 0     0 if (@_ and wantarray) {
834 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
835             }
836             else {
837 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
838             }
839             }
840             else {
841 0         0 return Char::Eusascii::uc_();
842             }
843             }
844              
845             #
846             # US-ASCII upper case without parameter
847             #
848             sub Char::Eusascii::uc_() {
849 0     0 0 0 my $s = $_;
850 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
851             }
852              
853             #
854             # US-ASCII fold case with parameter
855             #
856             sub Char::Eusascii::fc(@) {
857 0 0   0 0 0 if (@_) {
858 0         0 my $s = shift @_;
859 0 0 0     0 if (@_ and wantarray) {
860 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
861             }
862             else {
863 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
864             }
865             }
866             else {
867 0         0 return Char::Eusascii::fc_();
868             }
869             }
870              
871             #
872             # US-ASCII fold case without parameter
873             #
874             sub Char::Eusascii::fc_() {
875 0     0 0 0 my $s = $_;
876 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
877             }
878              
879             #
880             # US-ASCII regexp capture
881             #
882             {
883             sub Char::Eusascii::capture {
884 0     0 1 0 return $_[0];
885             }
886             }
887              
888             #
889             # US-ASCII regexp ignore case modifier
890             #
891             sub Char::Eusascii::ignorecase {
892              
893 0     0 0 0 my @string = @_;
894 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
895              
896             # ignore case of $scalar or @array
897 0         0 for my $string (@string) {
898              
899             # split regexp
900 0         0 my @char = $string =~ /\G(
901             \[\^ |
902             \\? (?:$q_char)
903             )/oxmsg;
904              
905             # unescape character
906 0         0 for (my $i=0; $i <= $#char; $i++) {
907 0 0       0 next if not defined $char[$i];
908              
909             # open character class [...]
910 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
911 0         0 my $left = $i;
912              
913             # [] make die "unmatched [] in regexp ..."
914              
915 0 0       0 if ($char[$i+1] eq ']') {
916 0         0 $i++;
917             }
918              
919 0         0 while (1) {
920 0 0       0 if (++$i > $#char) {
921 0         0 croak "Unmatched [] in regexp";
922             }
923 0 0       0 if ($char[$i] eq ']') {
924 0         0 my $right = $i;
925 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
926              
927             # escape character
928 0         0 for my $char (@charlist) {
929 0 0       0 if (0) {
930             }
931              
932 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
933 0         0 $char = $1 . '\\' . $char;
934             }
935             }
936              
937             # [...]
938 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
939              
940 0         0 $i = $left;
941 0         0 last;
942             }
943             }
944             }
945              
946             # open character class [^...]
947             elsif ($char[$i] eq '[^') {
948 0         0 my $left = $i;
949              
950             # [^] make die "unmatched [] in regexp ..."
951              
952 0 0       0 if ($char[$i+1] eq ']') {
953 0         0 $i++;
954             }
955              
956 0         0 while (1) {
957 0 0       0 if (++$i > $#char) {
958 0         0 croak "Unmatched [] in regexp";
959             }
960 0 0       0 if ($char[$i] eq ']') {
961 0         0 my $right = $i;
962 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
963              
964             # escape character
965 0         0 for my $char (@charlist) {
966 0 0       0 if (0) {
967             }
968              
969 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
970 0         0 $char = '\\' . $char;
971             }
972             }
973              
974             # [^...]
975 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
976              
977 0         0 $i = $left;
978 0         0 last;
979             }
980             }
981             }
982              
983             # rewrite classic character class or escape character
984             elsif (my $char = classic_character_class($char[$i])) {
985 0         0 $char[$i] = $char;
986             }
987              
988             # with /i modifier
989             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
990 0         0 my $uc = Char::Eusascii::uc($char[$i]);
991 0         0 my $fc = Char::Eusascii::fc($char[$i]);
992 0 0       0 if ($uc ne $fc) {
993 0 0       0 if (CORE::length($fc) == 1) {
994 0         0 $char[$i] = '[' . $uc . $fc . ']';
995             }
996             else {
997 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
998             }
999             }
1000             }
1001             }
1002              
1003             # characterize
1004 0         0 for (my $i=0; $i <= $#char; $i++) {
1005 0 0       0 next if not defined $char[$i];
1006              
1007 0 0       0 if (0) {
1008             }
1009              
1010             # quote character before ? + * {
1011 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1012 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1013 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1014             }
1015             }
1016             }
1017              
1018 0         0 $string = join '', @char;
1019             }
1020              
1021             # make regexp string
1022 0         0 return @string;
1023             }
1024              
1025             #
1026             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1027             #
1028             sub Char::Eusascii::classic_character_class {
1029 0     0 0 0 my($char) = @_;
1030              
1031             return {
1032 0   0     0 '\D' => '${Char::Eusascii::eD}',
1033             '\S' => '${Char::Eusascii::eS}',
1034             '\W' => '${Char::Eusascii::eW}',
1035             '\d' => '[0-9]',
1036              
1037             # Before Perl 5.6, \s only matched the five whitespace characters
1038             # tab, newline, form-feed, carriage return, and the space character
1039             # itself, which, taken together, is the character class [\t\n\f\r ].
1040              
1041             # Vertical tabs are now whitespace
1042             # \s in a regex now matches a vertical tab in all circumstances.
1043             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1044             # \t \n \v \f \r space
1045             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1046             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1047             '\s' => '\s',
1048              
1049             '\w' => '[0-9A-Z_a-z]',
1050             '\C' => '[\x00-\xFF]',
1051             '\X' => 'X',
1052              
1053             # \h \v \H \V
1054              
1055             # P.114 Character Class Shortcuts
1056             # in Chapter 7: In the World of Regular Expressions
1057             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1058              
1059             # P.357 13.2.3 Whitespace
1060             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1061             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1062             #
1063             # 0x00009 CHARACTER TABULATION h s
1064             # 0x0000a LINE FEED (LF) vs
1065             # 0x0000b LINE TABULATION v
1066             # 0x0000c FORM FEED (FF) vs
1067             # 0x0000d CARRIAGE RETURN (CR) vs
1068             # 0x00020 SPACE h s
1069              
1070             # P.196 Table 5-9. Alphanumeric regex metasymbols
1071             # in Chapter 5. Pattern Matching
1072             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1073              
1074             # (and so on)
1075              
1076             '\H' => '${Char::Eusascii::eH}',
1077             '\V' => '${Char::Eusascii::eV}',
1078             '\h' => '[\x09\x20]',
1079             '\v' => '[\x0A\x0B\x0C\x0D]',
1080             '\R' => '${Char::Eusascii::eR}',
1081              
1082             # \N
1083             #
1084             # http://perldoc.perl.org/perlre.html
1085             # Character Classes and other Special Escapes
1086             # Any character but \n (experimental). Not affected by /s modifier
1087              
1088             '\N' => '${Char::Eusascii::eN}',
1089              
1090             # \b \B
1091              
1092             # P.180 Boundaries: The \b and \B Assertions
1093             # in Chapter 5: Pattern Matching
1094             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1095              
1096             # P.219 Boundaries: The \b and \B Assertions
1097             # in Chapter 5: Pattern Matching
1098             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1099              
1100             # '\b' => '(?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))',
1101             '\b' => '${Char::Eusascii::eb}',
1102              
1103             # '\B' => '(?:(?<=\w)(?=\w)|(?<=\W)(?=\W))',
1104             '\B' => '${Char::Eusascii::eB}',
1105              
1106             }->{$char} || '';
1107             }
1108              
1109             #
1110             # prepare US-ASCII characters per length
1111             #
1112              
1113             # 1 octet characters
1114             my @chars1 = ();
1115             sub chars1 {
1116 0 0   0 0 0 if (@chars1) {
1117 0         0 return @chars1;
1118             }
1119 0 0       0 if (exists $range_tr{1}) {
1120 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1121 0         0 while (my @range = splice(@ranges,0,1)) {
1122 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1123 0         0 push @chars1, pack 'C', $oct0;
1124             }
1125             }
1126             }
1127 0         0 return @chars1;
1128             }
1129              
1130             # 2 octets characters
1131             my @chars2 = ();
1132             sub chars2 {
1133 0 0   0 0 0 if (@chars2) {
1134 0         0 return @chars2;
1135             }
1136 0 0       0 if (exists $range_tr{2}) {
1137 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1138 0         0 while (my @range = splice(@ranges,0,2)) {
1139 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1140 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1141 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1142             }
1143             }
1144             }
1145             }
1146 0         0 return @chars2;
1147             }
1148              
1149             # 3 octets characters
1150             my @chars3 = ();
1151             sub chars3 {
1152 0 0   0 0 0 if (@chars3) {
1153 0         0 return @chars3;
1154             }
1155 0 0       0 if (exists $range_tr{3}) {
1156 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1157 0         0 while (my @range = splice(@ranges,0,3)) {
1158 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1159 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1160 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1161 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1162             }
1163             }
1164             }
1165             }
1166             }
1167 0         0 return @chars3;
1168             }
1169              
1170             # 4 octets characters
1171             my @chars4 = ();
1172             sub chars4 {
1173 0 0   0 0 0 if (@chars4) {
1174 0         0 return @chars4;
1175             }
1176 0 0       0 if (exists $range_tr{4}) {
1177 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1178 0         0 while (my @range = splice(@ranges,0,4)) {
1179 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1180 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1181 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1182 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1183 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1184             }
1185             }
1186             }
1187             }
1188             }
1189             }
1190 0         0 return @chars4;
1191             }
1192              
1193             #
1194             # US-ASCII open character list for tr
1195             #
1196             sub _charlist_tr {
1197              
1198 0     0   0 local $_ = shift @_;
1199              
1200             # unescape character
1201 0         0 my @char = ();
1202 0         0 while (not /\G \z/oxmsgc) {
1203 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1204 0         0 push @char, '\-';
1205             }
1206             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1207 0         0 push @char, CORE::chr(oct $1);
1208             }
1209             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1210 0         0 push @char, CORE::chr(hex $1);
1211             }
1212             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1213 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1214             }
1215             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1216 0         0 push @char, {
1217             '\0' => "\0",
1218             '\n' => "\n",
1219             '\r' => "\r",
1220             '\t' => "\t",
1221             '\f' => "\f",
1222             '\b' => "\x08", # \b means backspace in character class
1223             '\a' => "\a",
1224             '\e' => "\e",
1225             }->{$1};
1226             }
1227             elsif (/\G \\ ($q_char) /oxmsgc) {
1228 0         0 push @char, $1;
1229             }
1230             elsif (/\G ($q_char) /oxmsgc) {
1231 0         0 push @char, $1;
1232             }
1233             }
1234              
1235             # join separated multiple-octet
1236 0         0 @char = join('',@char) =~ /\G (\\-|$q_char) /oxmsg;
1237              
1238             # unescape '-'
1239 0         0 my @i = ();
1240 0         0 for my $i (0 .. $#char) {
1241 0 0       0 if ($char[$i] eq '\-') {
    0          
1242 0         0 $char[$i] = '-';
1243             }
1244             elsif ($char[$i] eq '-') {
1245 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1246 0         0 push @i, $i;
1247             }
1248             }
1249             }
1250              
1251             # open character list (reverse for splice)
1252 0         0 for my $i (CORE::reverse @i) {
1253 0         0 my @range = ();
1254              
1255             # range error
1256 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1257 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1258             }
1259              
1260             # range of multiple-octet code
1261 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1262 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1263 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1264             }
1265             elsif (CORE::length($char[$i+1]) == 2) {
1266 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1267 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1268             }
1269             elsif (CORE::length($char[$i+1]) == 3) {
1270 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1271 0         0 push @range, chars2();
1272 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1273             }
1274             elsif (CORE::length($char[$i+1]) == 4) {
1275 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1276 0         0 push @range, chars2();
1277 0         0 push @range, chars3();
1278 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1279             }
1280             else {
1281 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1282             }
1283             }
1284             elsif (CORE::length($char[$i-1]) == 2) {
1285 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1286 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1287             }
1288             elsif (CORE::length($char[$i+1]) == 3) {
1289 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1290 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1291             }
1292             elsif (CORE::length($char[$i+1]) == 4) {
1293 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1294 0         0 push @range, chars3();
1295 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1296             }
1297             else {
1298 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1299             }
1300             }
1301             elsif (CORE::length($char[$i-1]) == 3) {
1302 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1303 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1304             }
1305             elsif (CORE::length($char[$i+1]) == 4) {
1306 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1307 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1308             }
1309             else {
1310 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1311             }
1312             }
1313             elsif (CORE::length($char[$i-1]) == 4) {
1314 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1315 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1316             }
1317             else {
1318 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1319             }
1320             }
1321             else {
1322 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1323             }
1324              
1325 0         0 splice @char, $i-1, 3, @range;
1326             }
1327              
1328 0         0 return @char;
1329             }
1330              
1331             #
1332             # US-ASCII open character class
1333             #
1334             sub _cc {
1335 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1336 0         0 die __FILE__, ": subroutine cc got no parameter.";
1337             }
1338             elsif (scalar(@_) == 1) {
1339 0         0 return sprintf('\x%02X',$_[0]);
1340             }
1341             elsif (scalar(@_) == 2) {
1342 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1343 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).";
1344             }
1345             elsif ($_[0] == $_[1]) {
1346 0         0 return sprintf('\x%02X',$_[0]);
1347             }
1348             elsif (($_[0]+1) == $_[1]) {
1349 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1350             }
1351             else {
1352 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1353             }
1354             }
1355             else {
1356 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).";
  0         0  
1357             }
1358             }
1359              
1360             #
1361             # US-ASCII octet range
1362             #
1363             sub _octets {
1364 0     0   0 my $length = shift @_;
1365              
1366 0 0       0 if ($length == 1) {
1367 0         0 my($a1) = unpack 'C', $_[0];
1368 0         0 my($z1) = unpack 'C', $_[1];
1369              
1370 0 0       0 if ($a1 > $z1) {
1371 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1372             }
1373              
1374 0 0       0 if ($a1 == $z1) {
    0          
1375 0         0 return sprintf('\x%02X',$a1);
1376             }
1377             elsif (($a1+1) == $z1) {
1378 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1379             }
1380             else {
1381 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1382             }
1383             }
1384             else {
1385 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).";
1386             }
1387             }
1388              
1389             #
1390             # US-ASCII range regexp
1391             #
1392             sub _range_regexp {
1393 0     0   0 my($length,$first,$last) = @_;
1394              
1395 0         0 my @range_regexp = ();
1396 0 0       0 if (not exists $range_tr{$length}) {
1397 0         0 return @range_regexp;
1398             }
1399              
1400 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1401 0         0 while (my @range = splice(@ranges,0,$length)) {
1402 0         0 my $min = '';
1403 0         0 my $max = '';
1404 0         0 for (my $i=0; $i < $length; $i++) {
1405 0         0 $min .= pack 'C', $range[$i][0];
1406 0         0 $max .= pack 'C', $range[$i][-1];
1407             }
1408              
1409             # min___max
1410             # FIRST_____________LAST
1411             # (nothing)
1412              
1413 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1414             }
1415              
1416             # **********
1417             # min_________max
1418             # FIRST_____________LAST
1419             # **********
1420              
1421             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1422 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1423             }
1424              
1425             # **********************
1426             # min________________max
1427             # FIRST_____________LAST
1428             # **********************
1429              
1430             elsif (($min eq $first) and ($max eq $last)) {
1431 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1432             }
1433              
1434             # *********
1435             # min___max
1436             # FIRST_____________LAST
1437             # *********
1438              
1439             elsif (($first le $min) and ($max le $last)) {
1440 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1441             }
1442              
1443             # **********************
1444             # min__________________________max
1445             # FIRST_____________LAST
1446             # **********************
1447              
1448             elsif (($min le $first) and ($last le $max)) {
1449 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1450             }
1451              
1452             # *********
1453             # min________max
1454             # FIRST_____________LAST
1455             # *********
1456              
1457             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1458 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1459             }
1460              
1461             # min___max
1462             # FIRST_____________LAST
1463             # (nothing)
1464              
1465             elsif ($last lt $min) {
1466             }
1467              
1468             else {
1469 0         0 die __FILE__, ": subroutine _range_regexp panic.";
1470             }
1471             }
1472              
1473 0         0 return @range_regexp;
1474             }
1475              
1476             #
1477             # US-ASCII open character list for qr and not qr
1478             #
1479             sub _charlist {
1480              
1481 0     0   0 my $modifier = pop @_;
1482 0         0 my @char = @_;
1483              
1484 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1485              
1486             # unescape character
1487 0         0 for (my $i=0; $i <= $#char; $i++) {
1488              
1489             # escape - to ...
1490 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1491 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1492 0         0 $char[$i] = '...';
1493             }
1494             }
1495              
1496             # octal escape sequence
1497             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1498 0         0 $char[$i] = octchr($1);
1499             }
1500              
1501             # hexadecimal escape sequence
1502             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1503 0         0 $char[$i] = hexchr($1);
1504             }
1505              
1506             # \N{CHARNAME} --> N\{CHARNAME}
1507             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1508 0         0 $char[$i] = $1 . '\\' . $2;
1509             }
1510              
1511             # \p{PROPERTY} --> p\{PROPERTY}
1512             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1513 0         0 $char[$i] = $1 . '\\' . $2;
1514             }
1515              
1516             # \P{PROPERTY} --> P\{PROPERTY}
1517             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1518 0         0 $char[$i] = $1 . '\\' . $2;
1519             }
1520              
1521             # \p, \P, \X --> p, P, X
1522             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1523 0         0 $char[$i] = $1;
1524             }
1525              
1526             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1527 0         0 $char[$i] = CORE::chr oct $1;
1528             }
1529             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1530 0         0 $char[$i] = CORE::chr hex $1;
1531             }
1532             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1533 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1534             }
1535             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1536 0         0 $char[$i] = {
1537             '\0' => "\0",
1538             '\n' => "\n",
1539             '\r' => "\r",
1540             '\t' => "\t",
1541             '\f' => "\f",
1542             '\b' => "\x08", # \b means backspace in character class
1543             '\a' => "\a",
1544             '\e' => "\e",
1545             '\d' => '[0-9]',
1546              
1547             # Vertical tabs are now whitespace
1548             # \s in a regex now matches a vertical tab in all circumstances.
1549             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1550             # \t \n \v \f \r space
1551             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1552             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1553             '\s' => '\s',
1554              
1555             '\w' => '[0-9A-Z_a-z]',
1556             '\D' => '${Char::Eusascii::eD}',
1557             '\S' => '${Char::Eusascii::eS}',
1558             '\W' => '${Char::Eusascii::eW}',
1559              
1560             '\H' => '${Char::Eusascii::eH}',
1561             '\V' => '${Char::Eusascii::eV}',
1562             '\h' => '[\x09\x20]',
1563             '\v' => '[\x0A\x0B\x0C\x0D]',
1564             '\R' => '${Char::Eusascii::eR}',
1565              
1566             }->{$1};
1567             }
1568              
1569             # POSIX-style character classes
1570             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1571 0         0 $char[$i] = {
1572              
1573             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1574             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1575             '[:^lower:]' => '${Char::Eusascii::not_lower_i}',
1576             '[:^upper:]' => '${Char::Eusascii::not_upper_i}',
1577              
1578             }->{$1};
1579             }
1580             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1581 0         0 $char[$i] = {
1582              
1583             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1584             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1585             '[:ascii:]' => '[\x00-\x7F]',
1586             '[:blank:]' => '[\x09\x20]',
1587             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1588             '[:digit:]' => '[\x30-\x39]',
1589             '[:graph:]' => '[\x21-\x7F]',
1590             '[:lower:]' => '[\x61-\x7A]',
1591             '[:print:]' => '[\x20-\x7F]',
1592             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1593              
1594             # P.174 POSIX-Style Character Classes
1595             # in Chapter 5: Pattern Matching
1596             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1597              
1598             # P.311 11.2.4 Character Classes and other Special Escapes
1599             # in Chapter 11: perlre: Perl regular expressions
1600             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1601              
1602             # P.210 POSIX-Style Character Classes
1603             # in Chapter 5: Pattern Matching
1604             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1605              
1606             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1607              
1608             '[:upper:]' => '[\x41-\x5A]',
1609             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1610             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1611             '[:^alnum:]' => '${Char::Eusascii::not_alnum}',
1612             '[:^alpha:]' => '${Char::Eusascii::not_alpha}',
1613             '[:^ascii:]' => '${Char::Eusascii::not_ascii}',
1614             '[:^blank:]' => '${Char::Eusascii::not_blank}',
1615             '[:^cntrl:]' => '${Char::Eusascii::not_cntrl}',
1616             '[:^digit:]' => '${Char::Eusascii::not_digit}',
1617             '[:^graph:]' => '${Char::Eusascii::not_graph}',
1618             '[:^lower:]' => '${Char::Eusascii::not_lower}',
1619             '[:^print:]' => '${Char::Eusascii::not_print}',
1620             '[:^punct:]' => '${Char::Eusascii::not_punct}',
1621             '[:^space:]' => '${Char::Eusascii::not_space}',
1622             '[:^upper:]' => '${Char::Eusascii::not_upper}',
1623             '[:^word:]' => '${Char::Eusascii::not_word}',
1624             '[:^xdigit:]' => '${Char::Eusascii::not_xdigit}',
1625              
1626             }->{$1};
1627             }
1628             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1629 0         0 $char[$i] = $1;
1630             }
1631             }
1632              
1633             # open character list
1634 0         0 my @singleoctet = ();
1635 0         0 my @multipleoctet = ();
1636 0         0 for (my $i=0; $i <= $#char; ) {
1637              
1638             # escaped -
1639 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1640 0         0 $i += 1;
1641 0         0 next;
1642             }
1643              
1644             # make range regexp
1645             elsif ($char[$i] eq '...') {
1646              
1647             # range error
1648 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1649 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1650             }
1651             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1652 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1653 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1654             }
1655             }
1656              
1657             # make range regexp per length
1658 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1659 0         0 my @regexp = ();
1660              
1661             # is first and last
1662 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1663 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1664             }
1665              
1666             # is first
1667             elsif ($length == CORE::length($char[$i-1])) {
1668 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1669             }
1670              
1671             # is inside in first and last
1672             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1673 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1674             }
1675              
1676             # is last
1677             elsif ($length == CORE::length($char[$i+1])) {
1678 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1679             }
1680              
1681             else {
1682 0         0 die __FILE__, ": subroutine make_regexp panic.";
1683             }
1684              
1685 0 0       0 if ($length == 1) {
1686 0         0 push @singleoctet, @regexp;
1687             }
1688             else {
1689 0         0 push @multipleoctet, @regexp;
1690             }
1691             }
1692              
1693 0         0 $i += 2;
1694             }
1695              
1696             # with /i modifier
1697             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1698 0 0       0 if ($modifier =~ /i/oxms) {
1699 0         0 my $uc = Char::Eusascii::uc($char[$i]);
1700 0         0 my $fc = Char::Eusascii::fc($char[$i]);
1701 0 0       0 if ($uc ne $fc) {
1702 0 0       0 if (CORE::length($fc) == 1) {
1703 0         0 push @singleoctet, $uc, $fc;
1704             }
1705             else {
1706 0         0 push @singleoctet, $uc;
1707 0         0 push @multipleoctet, $fc;
1708             }
1709             }
1710             else {
1711 0         0 push @singleoctet, $char[$i];
1712             }
1713             }
1714             else {
1715 0         0 push @singleoctet, $char[$i];
1716             }
1717 0         0 $i += 1;
1718             }
1719              
1720             # single character of single octet code
1721             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1722 0         0 push @singleoctet, "\t", "\x20";
1723 0         0 $i += 1;
1724             }
1725             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1726 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1727 0         0 $i += 1;
1728             }
1729             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1730 0         0 push @singleoctet, $char[$i];
1731 0         0 $i += 1;
1732             }
1733              
1734             # single character of multiple-octet code
1735             else {
1736 0         0 push @multipleoctet, $char[$i];
1737 0         0 $i += 1;
1738             }
1739             }
1740              
1741             # quote metachar
1742 0         0 for (@singleoctet) {
1743 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1744 0         0 $_ = '-';
1745             }
1746             elsif (/\A \n \z/oxms) {
1747 0         0 $_ = '\n';
1748             }
1749             elsif (/\A \r \z/oxms) {
1750 0         0 $_ = '\r';
1751             }
1752             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1753 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1754             }
1755             elsif (/\A [\x00-\xFF] \z/oxms) {
1756 0         0 $_ = quotemeta $_;
1757             }
1758             }
1759              
1760             # return character list
1761 0         0 return \@singleoctet, \@multipleoctet;
1762             }
1763              
1764             #
1765             # US-ASCII octal escape sequence
1766             #
1767             sub octchr {
1768 0     0 0 0 my($octdigit) = @_;
1769              
1770 0         0 my @binary = ();
1771 0         0 for my $octal (split(//,$octdigit)) {
1772 0         0 push @binary, {
1773             '0' => '000',
1774             '1' => '001',
1775             '2' => '010',
1776             '3' => '011',
1777             '4' => '100',
1778             '5' => '101',
1779             '6' => '110',
1780             '7' => '111',
1781             }->{$octal};
1782             }
1783 0         0 my $binary = join '', @binary;
1784              
1785 0         0 my $octchr = {
1786             # 1234567
1787             1 => pack('B*', "0000000$binary"),
1788             2 => pack('B*', "000000$binary"),
1789             3 => pack('B*', "00000$binary"),
1790             4 => pack('B*', "0000$binary"),
1791             5 => pack('B*', "000$binary"),
1792             6 => pack('B*', "00$binary"),
1793             7 => pack('B*', "0$binary"),
1794             0 => pack('B*', "$binary"),
1795              
1796             }->{CORE::length($binary) % 8};
1797              
1798 0         0 return $octchr;
1799             }
1800              
1801             #
1802             # US-ASCII hexadecimal escape sequence
1803             #
1804             sub hexchr {
1805 0     0 0 0 my($hexdigit) = @_;
1806              
1807 0         0 my $hexchr = {
1808             1 => pack('H*', "0$hexdigit"),
1809             0 => pack('H*', "$hexdigit"),
1810              
1811             }->{CORE::length($_[0]) % 2};
1812              
1813 0         0 return $hexchr;
1814             }
1815              
1816             #
1817             # US-ASCII open character list for qr
1818             #
1819             sub charlist_qr {
1820              
1821 0     0 0 0 my $modifier = pop @_;
1822 0         0 my @char = @_;
1823              
1824 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1825 0         0 my @singleoctet = @$singleoctet;
1826 0         0 my @multipleoctet = @$multipleoctet;
1827              
1828             # return character list
1829 0 0       0 if (scalar(@singleoctet) >= 1) {
1830              
1831             # with /i modifier
1832 0 0       0 if ($modifier =~ m/i/oxms) {
1833 0         0 my %singleoctet_ignorecase = ();
1834 0         0 for (@singleoctet) {
1835 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1836 0         0 for my $ord (hex($1) .. hex($2)) {
1837 0         0 my $char = CORE::chr($ord);
1838 0         0 my $uc = Char::Eusascii::uc($char);
1839 0         0 my $fc = Char::Eusascii::fc($char);
1840 0 0       0 if ($uc eq $fc) {
1841 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1842             }
1843             else {
1844 0 0       0 if (CORE::length($fc) == 1) {
1845 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1846 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1847             }
1848             else {
1849 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1850 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1851             }
1852             }
1853             }
1854             }
1855 0 0       0 if ($_ ne '') {
1856 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1857             }
1858             }
1859 0         0 my $i = 0;
1860 0         0 my @singleoctet_ignorecase = ();
1861 0         0 for my $ord (0 .. 255) {
1862 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1863 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1864             }
1865             else {
1866 0         0 $i++;
1867             }
1868             }
1869 0         0 @singleoctet = ();
1870 0         0 for my $range (@singleoctet_ignorecase) {
1871 0 0       0 if (ref $range) {
1872 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
1873 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1874             }
1875             elsif (scalar(@{$range}) == 2) {
1876 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1877             }
1878             else {
1879 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1880             }
1881             }
1882             }
1883             }
1884              
1885 0         0 my $not_anchor = '';
1886              
1887 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
1888             }
1889 0 0       0 if (scalar(@multipleoctet) >= 2) {
1890 0         0 return '(?:' . join('|', @multipleoctet) . ')';
1891             }
1892             else {
1893 0         0 return $multipleoctet[0];
1894             }
1895             }
1896              
1897             #
1898             # US-ASCII open character list for not qr
1899             #
1900             sub charlist_not_qr {
1901              
1902 0     0 0 0 my $modifier = pop @_;
1903 0         0 my @char = @_;
1904              
1905 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1906 0         0 my @singleoctet = @$singleoctet;
1907 0         0 my @multipleoctet = @$multipleoctet;
1908              
1909             # with /i modifier
1910 0 0       0 if ($modifier =~ m/i/oxms) {
1911 0         0 my %singleoctet_ignorecase = ();
1912 0         0 for (@singleoctet) {
1913 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1914 0         0 for my $ord (hex($1) .. hex($2)) {
1915 0         0 my $char = CORE::chr($ord);
1916 0         0 my $uc = Char::Eusascii::uc($char);
1917 0         0 my $fc = Char::Eusascii::fc($char);
1918 0 0       0 if ($uc eq $fc) {
1919 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1920             }
1921             else {
1922 0 0       0 if (CORE::length($fc) == 1) {
1923 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1924 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1925             }
1926             else {
1927 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1928 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1929             }
1930             }
1931             }
1932             }
1933 0 0       0 if ($_ ne '') {
1934 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1935             }
1936             }
1937 0         0 my $i = 0;
1938 0         0 my @singleoctet_ignorecase = ();
1939 0         0 for my $ord (0 .. 255) {
1940 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1941 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1942             }
1943             else {
1944 0         0 $i++;
1945             }
1946             }
1947 0         0 @singleoctet = ();
1948 0         0 for my $range (@singleoctet_ignorecase) {
1949 0 0       0 if (ref $range) {
1950 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
1951 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1952             }
1953             elsif (scalar(@{$range}) == 2) {
1954 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1955             }
1956             else {
1957 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1958             }
1959             }
1960             }
1961             }
1962              
1963             # return character list
1964 0 0       0 if (scalar(@multipleoctet) >= 1) {
1965 0 0       0 if (scalar(@singleoctet) >= 1) {
1966              
1967             # any character other than multiple-octet and single octet character class
1968 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
1969             }
1970             else {
1971              
1972             # any character other than multiple-octet character class
1973 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
1974             }
1975             }
1976             else {
1977 0 0       0 if (scalar(@singleoctet) >= 1) {
1978              
1979             # any character other than single octet character class
1980 0         0 return '(?:[^' . join('', @singleoctet) . '])';
1981             }
1982             else {
1983              
1984             # any character
1985 0         0 return "(?:$your_char)";
1986             }
1987             }
1988             }
1989              
1990             #
1991             # open file in read mode
1992             #
1993             sub _open_r {
1994 197     197   615 my(undef,$file) = @_;
1995 197         866 $file =~ s#\A (\s) #./$1#oxms;
1996 197   33     31570 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
1997             open($_[0],"< $file\0");
1998             }
1999              
2000             #
2001             # open file in write mode
2002             #
2003             sub _open_w {
2004 0     0   0 my(undef,$file) = @_;
2005 0         0 $file =~ s#\A (\s) #./$1#oxms;
2006 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2007             open($_[0],"> $file\0");
2008             }
2009              
2010             #
2011             # open file in append mode
2012             #
2013             sub _open_a {
2014 0     0   0 my(undef,$file) = @_;
2015 0         0 $file =~ s#\A (\s) #./$1#oxms;
2016 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2017             open($_[0],">> $file\0");
2018             }
2019              
2020             #
2021             # safe system
2022             #
2023             sub _systemx {
2024              
2025             # P.707 29.2.33. exec
2026             # in Chapter 29: Functions
2027             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2028             #
2029             # Be aware that in older releases of Perl, exec (and system) did not flush
2030             # your output buffer, so you needed to enable command buffering by setting $|
2031             # on one or more filehandles to avoid lost output in the case of exec, or
2032             # misordererd output in the case of system. This situation was largely remedied
2033             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2034              
2035             # P.855 exec
2036             # in Chapter 27: Functions
2037             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2038             #
2039             # In very old release of Perl (before v5.6), exec (and system) did not flush
2040             # your output buffer, so you needed to enable command buffering by setting $|
2041             # on one or more filehandles to avoid lost output with exec or misordered
2042             # output with system.
2043              
2044 197     197   735 $| = 1;
2045              
2046             # P.565 23.1.2. Cleaning Up Your Environment
2047             # in Chapter 23: Security
2048             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2049              
2050             # P.656 Cleaning Up Your Environment
2051             # in Chapter 20: Security
2052             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2053              
2054             # local $ENV{'PATH'} = '.';
2055 197         2185 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2056              
2057             # P.707 29.2.33. exec
2058             # in Chapter 29: Functions
2059             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2060             #
2061             # As we mentioned earlier, exec treats a discrete list of arguments as an
2062             # indication that it should bypass shell processing. However, there is one
2063             # place where you might still get tripped up. The exec call (and system, too)
2064             # will not distinguish between a single scalar argument and an array containing
2065             # only one element.
2066             #
2067             # @args = ("echo surprise"); # just one element in list
2068             # exec @args # still subject to shell escapes
2069             # or die "exec: $!"; # because @args == 1
2070             #
2071             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2072             # first argument as the pathname, which forces the rest of the arguments to be
2073             # interpreted as a list, even if there is only one of them:
2074             #
2075             # exec { $args[0] } @args # safe even with one-argument list
2076             # or die "can't exec @args: $!";
2077              
2078             # P.855 exec
2079             # in Chapter 27: Functions
2080             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2081             #
2082             # As we mentioned earlier, exec treats a discrete list of arguments as a
2083             # directive to bypass shell processing. However, there is one place where
2084             # you might still get tripped up. The exec call (and system, too) cannot
2085             # distinguish between a single scalar argument and an array containing
2086             # only one element.
2087             #
2088             # @args = ("echo surprise"); # just one element in list
2089             # exec @args # still subject to shell escapes
2090             # || die "exec: $!"; # because @args == 1
2091             #
2092             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2093             # argument as the pathname, which forces the rest of the arguments to be
2094             # interpreted as a list, even if there is only one of them:
2095             #
2096             # exec { $args[0] } @args # safe even with one-argument list
2097             # || die "can't exec @args: $!";
2098              
2099 197         467 return CORE::system { $_[0] } @_; # safe even with one-argument list
  197         21474412  
2100             }
2101              
2102             #
2103             # US-ASCII order to character (with parameter)
2104             #
2105             sub Char::Eusascii::chr(;$) {
2106              
2107 0 0   0 0   my $c = @_ ? $_[0] : $_;
2108              
2109 0 0         if ($c == 0x00) {
2110 0           return "\x00";
2111             }
2112             else {
2113 0           my @chr = ();
2114 0           while ($c > 0) {
2115 0           unshift @chr, ($c % 0x100);
2116 0           $c = int($c / 0x100);
2117             }
2118 0           return pack 'C*', @chr;
2119             }
2120             }
2121              
2122             #
2123             # US-ASCII order to character (without parameter)
2124             #
2125             sub Char::Eusascii::chr_() {
2126              
2127 0     0 0   my $c = $_;
2128              
2129 0 0         if ($c == 0x00) {
2130 0           return "\x00";
2131             }
2132             else {
2133 0           my @chr = ();
2134 0           while ($c > 0) {
2135 0           unshift @chr, ($c % 0x100);
2136 0           $c = int($c / 0x100);
2137             }
2138 0           return pack 'C*', @chr;
2139             }
2140             }
2141              
2142             #
2143             # US-ASCII path globbing (with parameter)
2144             #
2145             sub Char::Eusascii::glob($) {
2146              
2147 0 0   0 0   if (wantarray) {
2148 0           my @glob = _DOS_like_glob(@_);
2149 0           for my $glob (@glob) {
2150 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2151             }
2152 0           return @glob;
2153             }
2154             else {
2155 0           my $glob = _DOS_like_glob(@_);
2156 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2157 0           return $glob;
2158             }
2159             }
2160              
2161             #
2162             # US-ASCII path globbing (without parameter)
2163             #
2164             sub Char::Eusascii::glob_() {
2165              
2166 0 0   0 0   if (wantarray) {
2167 0           my @glob = _DOS_like_glob();
2168 0           for my $glob (@glob) {
2169 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2170             }
2171 0           return @glob;
2172             }
2173             else {
2174 0           my $glob = _DOS_like_glob();
2175 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2176 0           return $glob;
2177             }
2178             }
2179              
2180             #
2181             # US-ASCII path globbing via File::DosGlob 1.10
2182             #
2183             # Often I confuse "_dosglob" and "_doglob".
2184             # So, I renamed "_dosglob" to "_DOS_like_glob".
2185             #
2186             my %iter;
2187             my %entries;
2188             sub _DOS_like_glob {
2189              
2190             # context (keyed by second cxix argument provided by core)
2191 0     0     my($expr,$cxix) = @_;
2192              
2193             # glob without args defaults to $_
2194 0 0         $expr = $_ if not defined $expr;
2195              
2196             # represents the current user's home directory
2197             #
2198             # 7.3. Expanding Tildes in Filenames
2199             # in Chapter 7. File Access
2200             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2201             #
2202             # and File::HomeDir, File::HomeDir::Windows module
2203              
2204             # DOS-like system
2205 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2206 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2207 0           { my_home_MSWin32() }oxmse;
2208             }
2209              
2210             # UNIX-like system
2211             else {
2212 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2213 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2214             }
2215              
2216             # assume global context if not provided one
2217 0 0         $cxix = '_G_' if not defined $cxix;
2218 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2219              
2220             # if we're just beginning, do it all first
2221 0 0         if ($iter{$cxix} == 0) {
2222 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2223             }
2224              
2225             # chuck it all out, quick or slow
2226 0 0         if (wantarray) {
2227 0           delete $iter{$cxix};
2228 0           return @{delete $entries{$cxix}};
  0            
2229             }
2230             else {
2231 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2232 0           return shift @{$entries{$cxix}};
  0            
2233             }
2234             else {
2235             # return undef for EOL
2236 0           delete $iter{$cxix};
2237 0           delete $entries{$cxix};
2238 0           return undef;
2239             }
2240             }
2241             }
2242              
2243             #
2244             # US-ASCII path globbing subroutine
2245             #
2246             sub _do_glob {
2247              
2248 0     0     my($cond,@expr) = @_;
2249 0           my @glob = ();
2250 0           my $fix_drive_relative_paths = 0;
2251              
2252             OUTER:
2253 0           for my $expr (@expr) {
2254 0 0         next OUTER if not defined $expr;
2255 0 0         next OUTER if $expr eq '';
2256              
2257 0           my @matched = ();
2258 0           my @globdir = ();
2259 0           my $head = '.';
2260 0           my $pathsep = '/';
2261 0           my $tail;
2262              
2263             # if argument is within quotes strip em and do no globbing
2264 0 0         if ($expr =~ /\A " ((?:$q_char)*) " \z/oxms) {
2265 0           $expr = $1;
2266 0 0         if ($cond eq 'd') {
2267 0 0         if (-d $expr) {
2268 0           push @glob, $expr;
2269             }
2270             }
2271             else {
2272 0 0         if (-e $expr) {
2273 0           push @glob, $expr;
2274             }
2275             }
2276 0           next OUTER;
2277             }
2278              
2279             # wildcards with a drive prefix such as h:*.pm must be changed
2280             # to h:./*.pm to expand correctly
2281 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2282 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2283 0           $fix_drive_relative_paths = 1;
2284             }
2285             }
2286              
2287 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2288 0 0         if ($tail eq '') {
2289 0           push @glob, $expr;
2290 0           next OUTER;
2291             }
2292 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2293 0 0         if (@globdir = _do_glob('d', $head)) {
2294 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2295 0           next OUTER;
2296             }
2297             }
2298 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2299 0           $head .= $pathsep;
2300             }
2301 0           $expr = $tail;
2302             }
2303              
2304             # If file component has no wildcards, we can avoid opendir
2305 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2306 0 0         if ($head eq '.') {
2307 0           $head = '';
2308             }
2309 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2310 0           $head .= $pathsep;
2311             }
2312 0           $head .= $expr;
2313 0 0         if ($cond eq 'd') {
2314 0 0         if (-d $head) {
2315 0           push @glob, $head;
2316             }
2317             }
2318             else {
2319 0 0         if (-e $head) {
2320 0           push @glob, $head;
2321             }
2322             }
2323 0           next OUTER;
2324             }
2325 0 0         opendir(*DIR, $head) or next OUTER;
2326 0           my @leaf = readdir DIR;
2327 0           closedir DIR;
2328              
2329 0 0         if ($head eq '.') {
2330 0           $head = '';
2331             }
2332 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2333 0           $head .= $pathsep;
2334             }
2335              
2336 0           my $pattern = '';
2337 0           while ($expr =~ / \G ($q_char) /oxgc) {
2338 0           my $char = $1;
2339              
2340             # 6.9. Matching Shell Globs as Regular Expressions
2341             # in Chapter 6. Pattern Matching
2342             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2343             # (and so on)
2344              
2345 0 0         if ($char eq '*') {
    0          
    0          
2346 0           $pattern .= "(?:$your_char)*",
2347             }
2348             elsif ($char eq '?') {
2349 0           $pattern .= "(?:$your_char)?", # DOS style
2350             # $pattern .= "(?:$your_char)", # UNIX style
2351             }
2352             elsif ((my $fc = Char::Eusascii::fc($char)) ne $char) {
2353 0           $pattern .= $fc;
2354             }
2355             else {
2356 0           $pattern .= quotemeta $char;
2357             }
2358             }
2359 0     0     my $matchsub = sub { Char::Eusascii::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2360              
2361             # if ($@) {
2362             # print STDERR "$0: $@\n";
2363             # next OUTER;
2364             # }
2365              
2366             INNER:
2367 0           for my $leaf (@leaf) {
2368 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2369 0           next INNER;
2370             }
2371 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2372 0           next INNER;
2373             }
2374              
2375 0 0         if (&$matchsub($leaf)) {
2376 0           push @matched, "$head$leaf";
2377 0           next INNER;
2378             }
2379              
2380             # [DOS compatibility special case]
2381             # Failed, add a trailing dot and try again, but only...
2382              
2383 0 0 0       if (Char::Eusascii::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2384             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2385             Char::Eusascii::index($pattern,'\\.') != -1 # pattern has a dot.
2386             ) {
2387 0 0         if (&$matchsub("$leaf.")) {
2388 0           push @matched, "$head$leaf";
2389 0           next INNER;
2390             }
2391             }
2392             }
2393 0 0         if (@matched) {
2394 0           push @glob, @matched;
2395             }
2396             }
2397 0 0         if ($fix_drive_relative_paths) {
2398 0           for my $glob (@glob) {
2399 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2400             }
2401             }
2402 0           return @glob;
2403             }
2404              
2405             #
2406             # US-ASCII parse line
2407             #
2408             sub _parse_line {
2409              
2410 0     0     my($line) = @_;
2411              
2412 0           $line .= ' ';
2413 0           my @piece = ();
2414 0           while ($line =~ /
2415             " ( (?: [^"] )* ) " \s+ |
2416             ( (?: [^"\s] )* ) \s+
2417             /oxmsg
2418             ) {
2419 0 0         push @piece, defined($1) ? $1 : $2;
2420             }
2421 0           return @piece;
2422             }
2423              
2424             #
2425             # US-ASCII parse path
2426             #
2427             sub _parse_path {
2428              
2429 0     0     my($path,$pathsep) = @_;
2430              
2431 0           $path .= '/';
2432 0           my @subpath = ();
2433 0           while ($path =~ /
2434             ((?: [^\/\\] )+?) [\/\\]
2435             /oxmsg
2436             ) {
2437 0           push @subpath, $1;
2438             }
2439              
2440 0           my $tail = pop @subpath;
2441 0           my $head = join $pathsep, @subpath;
2442 0           return $head, $tail;
2443             }
2444              
2445             #
2446             # via File::HomeDir::Windows 1.00
2447             #
2448             sub my_home_MSWin32 {
2449              
2450             # A lot of unix people and unix-derived tools rely on
2451             # the ability to overload HOME. We will support it too
2452             # so that they can replace raw HOME calls with File::HomeDir.
2453 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2454 0           return $ENV{'HOME'};
2455             }
2456              
2457             # Do we have a user profile?
2458             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2459 0           return $ENV{'USERPROFILE'};
2460             }
2461              
2462             # Some Windows use something like $ENV{'HOME'}
2463             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2464 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2465             }
2466              
2467 0           return undef;
2468             }
2469              
2470             #
2471             # via File::HomeDir::Unix 1.00
2472             #
2473             sub my_home {
2474 0     0 0   my $home;
2475              
2476 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2477 0           $home = $ENV{'HOME'};
2478             }
2479              
2480             # This is from the original code, but I'm guessing
2481             # it means "login directory" and exists on some Unixes.
2482             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2483 0           $home = $ENV{'LOGDIR'};
2484             }
2485              
2486             ### More-desperate methods
2487              
2488             # Light desperation on any (Unixish) platform
2489             else {
2490 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2491             }
2492              
2493             # On Unix in general, a non-existant home means "no home"
2494             # For example, "nobody"-like users might use /nonexistant
2495 0 0 0       if (defined $home and ! -d($home)) {
2496 0           $home = undef;
2497             }
2498 0           return $home;
2499             }
2500              
2501             #
2502             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2503             #
2504             sub Char::Eusascii::PREMATCH {
2505 0     0 0   return $`;
2506             }
2507              
2508             #
2509             # ${^MATCH}, $MATCH, $& the string that matched
2510             #
2511             sub Char::Eusascii::MATCH {
2512 0     0 0   return $&;
2513             }
2514              
2515             #
2516             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2517             #
2518             sub Char::Eusascii::POSTMATCH {
2519 0     0 0   return $';
2520             }
2521              
2522             #
2523             # US-ASCII character to order (with parameter)
2524             #
2525             sub Char::USASCII::ord(;$) {
2526              
2527 0 0   0 1   local $_ = shift if @_;
2528              
2529 0 0         if (/\A ($q_char) /oxms) {
2530 0           my @ord = unpack 'C*', $1;
2531 0           my $ord = 0;
2532 0           while (my $o = shift @ord) {
2533 0           $ord = $ord * 0x100 + $o;
2534             }
2535 0           return $ord;
2536             }
2537             else {
2538 0           return CORE::ord $_;
2539             }
2540             }
2541              
2542             #
2543             # US-ASCII character to order (without parameter)
2544             #
2545             sub Char::USASCII::ord_() {
2546              
2547 0 0   0 0   if (/\A ($q_char) /oxms) {
2548 0           my @ord = unpack 'C*', $1;
2549 0           my $ord = 0;
2550 0           while (my $o = shift @ord) {
2551 0           $ord = $ord * 0x100 + $o;
2552             }
2553 0           return $ord;
2554             }
2555             else {
2556 0           return CORE::ord $_;
2557             }
2558             }
2559              
2560             #
2561             # US-ASCII reverse
2562             #
2563             sub Char::USASCII::reverse(@) {
2564              
2565 0 0   0 0   if (wantarray) {
2566 0           return CORE::reverse @_;
2567             }
2568             else {
2569              
2570             # One of us once cornered Larry in an elevator and asked him what
2571             # problem he was solving with this, but he looked as far off into
2572             # the distance as he could in an elevator and said, "It seemed like
2573             # a good idea at the time."
2574              
2575 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2576             }
2577             }
2578              
2579             #
2580             # US-ASCII getc (with parameter, without parameter)
2581             #
2582             sub Char::USASCII::getc(;*@) {
2583              
2584 0     0 0   my($package) = caller;
2585 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2586 0 0 0       croak 'Too many arguments for Char::USASCII::getc' if @_ and not wantarray;
2587              
2588 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2589 0           my $getc = '';
2590 0           for my $length ($length[0] .. $length[-1]) {
2591 0           $getc .= CORE::getc($fh);
2592 0 0         if (exists $range_tr{CORE::length($getc)}) {
2593 0 0         if ($getc =~ /\A ${Char::Eusascii::dot_s} \z/oxms) {
2594 0 0         return wantarray ? ($getc,@_) : $getc;
2595             }
2596             }
2597             }
2598 0 0         return wantarray ? ($getc,@_) : $getc;
2599             }
2600              
2601             #
2602             # US-ASCII length by character
2603             #
2604             sub Char::USASCII::length(;$) {
2605              
2606 0 0   0 1   local $_ = shift if @_;
2607              
2608 0           local @_ = /\G ($q_char) /oxmsg;
2609 0           return scalar @_;
2610             }
2611              
2612             #
2613             # US-ASCII substr by character
2614             #
2615             BEGIN {
2616              
2617             # P.232 The lvalue Attribute
2618             # in Chapter 6: Subroutines
2619             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2620              
2621             # P.336 The lvalue Attribute
2622             # in Chapter 7: Subroutines
2623             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2624              
2625             # P.144 8.4 Lvalue subroutines
2626             # in Chapter 8: perlsub: Perl subroutines
2627             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2628              
2629 197 50 0 197 1 138696 CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
  0 0   0      
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
2630             # vv----------------*******
2631             sub Char::USASCII::substr($$;$$) %s {
2632              
2633             my @char = $_[0] =~ /\G ($q_char) /oxmsg;
2634              
2635             # If the substring is beyond either end of the string, substr() returns the undefined
2636             # value and produces a warning. When used as an lvalue, specifying a substring that
2637             # is entirely outside the string raises an exception.
2638             # http://perldoc.perl.org/functions/substr.html
2639              
2640             # A return with no argument returns the scalar value undef in scalar context,
2641             # an empty list () in list context, and (naturally) nothing at all in void
2642             # context.
2643              
2644             my $offset = $_[1];
2645             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2646             return;
2647             }
2648              
2649             # substr($string,$offset,$length,$replacement)
2650             if (@_ == 4) {
2651             my(undef,undef,$length,$replacement) = @_;
2652             my $substr = join '', splice(@char, $offset, $length, $replacement);
2653             $_[0] = join '', @char;
2654              
2655             # return $substr; this doesn't work, don't say "return"
2656             $substr;
2657             }
2658              
2659             # substr($string,$offset,$length)
2660             elsif (@_ == 3) {
2661             my(undef,undef,$length) = @_;
2662             my $octet_offset = 0;
2663             my $octet_length = 0;
2664             if ($offset == 0) {
2665             $octet_offset = 0;
2666             }
2667             elsif ($offset > 0) {
2668             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2669             }
2670             else {
2671             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2672             }
2673             if ($length == 0) {
2674             $octet_length = 0;
2675             }
2676             elsif ($length > 0) {
2677             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2678             }
2679             else {
2680             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2681             }
2682             CORE::substr($_[0], $octet_offset, $octet_length);
2683             }
2684              
2685             # substr($string,$offset)
2686             else {
2687             my $octet_offset = 0;
2688             if ($offset == 0) {
2689             $octet_offset = 0;
2690             }
2691             elsif ($offset > 0) {
2692             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2693             }
2694             else {
2695             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2696             }
2697             CORE::substr($_[0], $octet_offset);
2698             }
2699             }
2700             END
2701             }
2702              
2703             #
2704             # US-ASCII index by character
2705             #
2706             sub Char::USASCII::index($$;$) {
2707              
2708 0     0 1   my $index;
2709 0 0         if (@_ == 3) {
2710 0           $index = Char::Eusascii::index($_[0], $_[1], CORE::length(Char::USASCII::substr($_[0], 0, $_[2])));
2711             }
2712             else {
2713 0           $index = Char::Eusascii::index($_[0], $_[1]);
2714             }
2715              
2716 0 0         if ($index == -1) {
2717 0           return -1;
2718             }
2719             else {
2720 0           return Char::USASCII::length(CORE::substr $_[0], 0, $index);
2721             }
2722             }
2723              
2724             #
2725             # US-ASCII rindex by character
2726             #
2727             sub Char::USASCII::rindex($$;$) {
2728              
2729 0     0 1   my $rindex;
2730 0 0         if (@_ == 3) {
2731 0           $rindex = Char::Eusascii::rindex($_[0], $_[1], CORE::length(Char::USASCII::substr($_[0], 0, $_[2])));
2732             }
2733             else {
2734 0           $rindex = Char::Eusascii::rindex($_[0], $_[1]);
2735             }
2736              
2737 0 0         if ($rindex == -1) {
2738 0           return -1;
2739             }
2740             else {
2741 0           return Char::USASCII::length(CORE::substr $_[0], 0, $rindex);
2742             }
2743             }
2744              
2745             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2746             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2747 197     197   17109 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  197     197   1939  
  197         402  
  197         15606  
2748              
2749             # ord() to ord() or Char::USASCII::ord()
2750 197     197   19525 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  197     197   1351  
  197         404  
  197         11984  
2751              
2752             # ord to ord or Char::USASCII::ord_
2753 197     197   11487 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  197     197   1206  
  197         404  
  197         15046  
2754              
2755             # reverse to reverse or Char::USASCII::reverse
2756 197     197   11980 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  197     197   1194  
  197         581  
  197         17087  
2757              
2758             # getc to getc or Char::USASCII::getc
2759 197     197   12133 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  197     197   1281  
  197         364  
  197         13811  
2760              
2761             # P.1023 Appendix W.9 Multibyte Anchoring
2762             # of ISBN 1-56592-224-7 CJKV Information Processing
2763              
2764             my $anchor = '';
2765              
2766 197     197   12014 BEGIN { CORE::eval q{ use vars qw($nest) } }
  197     197   1159  
  197         383  
  197         11427094  
2767              
2768             # regexp of nested parens in qqXX
2769              
2770             # P.340 Matching Nested Constructs with Embedded Code
2771             # in Chapter 7: Perl
2772             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2773              
2774             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2775             \\c[\x40-\x5F] |
2776             \\ [\x00-\xFF] |
2777             [^()] |
2778             \( (?{$nest++}) |
2779             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2780             }xms;
2781             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2782             \\c[\x40-\x5F] |
2783             \\ [\x00-\xFF] |
2784             [^{}] |
2785             \{ (?{$nest++}) |
2786             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2787             }xms;
2788             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2789             \\c[\x40-\x5F] |
2790             \\ [\x00-\xFF] |
2791             [^[\]] |
2792             \[ (?{$nest++}) |
2793             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2794             }xms;
2795             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2796             \\c[\x40-\x5F] |
2797             \\ [\x00-\xFF] |
2798             [^<>] |
2799             \< (?{$nest++}) |
2800             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2801             }xms;
2802             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2803             (?: ::)? (?:
2804             [a-zA-Z_][a-zA-Z_0-9]*
2805             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2806             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2807             ))
2808             }xms;
2809             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2810             (?: ::)? (?:
2811             [0-9]+ |
2812             [^a-zA-Z_0-9\[\]] |
2813             ^[A-Z] |
2814             [a-zA-Z_][a-zA-Z_0-9]*
2815             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2816             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2817             ))
2818             }xms;
2819             my $qq_substr = qr{(?: Char::USASCII::substr | CORE::substr | substr ) \( $qq_paren \)
2820             }xms;
2821              
2822             # regexp of nested parens in qXX
2823             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2824             [^()] |
2825             \( (?{$nest++}) |
2826             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2827             }xms;
2828             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2829             [^{}] |
2830             \{ (?{$nest++}) |
2831             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2832             }xms;
2833             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2834             [^[\]] |
2835             \[ (?{$nest++}) |
2836             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2837             }xms;
2838             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2839             [^<>] |
2840             \< (?{$nest++}) |
2841             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2842             }xms;
2843              
2844             my $matched = '';
2845             my $s_matched = '';
2846              
2847             my $tr_variable = ''; # variable of tr///
2848             my $sub_variable = ''; # variable of s///
2849             my $bind_operator = ''; # =~ or !~
2850              
2851             my @heredoc = (); # here document
2852             my @heredoc_delimiter = ();
2853             my $here_script = ''; # here script
2854              
2855             #
2856             # escape US-ASCII script
2857             #
2858             sub Char::USASCII::escape(;$) {
2859 0 0   0 0   local($_) = $_[0] if @_;
2860              
2861             # P.359 The Study Function
2862             # in Chapter 7: Perl
2863             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2864              
2865 0           study $_; # Yes, I studied study yesterday.
2866              
2867             # while all script
2868              
2869             # 6.14. Matching from Where the Last Pattern Left Off
2870             # in Chapter 6. Pattern Matching
2871             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2872             # (and so on)
2873              
2874             # one member of Tag-team
2875             #
2876             # P.128 Start of match (or end of previous match): \G
2877             # P.130 Advanced Use of \G with Perl
2878             # in Chapter 3: Overview of Regular Expression Features and Flavors
2879             # P.255 Use leading anchors
2880             # P.256 Expose ^ and \G at the front expressions
2881             # in Chapter 6: Crafting an Efficient Expression
2882             # P.315 "Tag-team" matching with /gc
2883             # in Chapter 7: Perl
2884             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2885              
2886 0           my $e_script = '';
2887 0           while (not /\G \z/oxgc) { # member
2888 0           $e_script .= Char::USASCII::escape_token();
2889             }
2890              
2891 0           return $e_script;
2892             }
2893              
2894             #
2895             # escape US-ASCII token of script
2896             #
2897             sub Char::USASCII::escape_token {
2898              
2899             # \n output here document
2900              
2901 0     0 0   my $ignore_modules = join('|', qw(
2902             utf8
2903             bytes
2904             charnames
2905             I18N::Japanese
2906             I18N::Collate
2907             I18N::JExt
2908             File::DosGlob
2909             Wild
2910             Wildcard
2911             Japanese
2912             ));
2913              
2914             # another member of Tag-team
2915             #
2916             # P.315 "Tag-team" matching with /gc
2917             # in Chapter 7: Perl
2918             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2919              
2920 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          
    0          
    0          
2921 0           my $heredoc = '';
2922 0 0         if (scalar(@heredoc_delimiter) >= 1) {
2923 0           $slash = 'm//';
2924              
2925 0           $heredoc = join '', @heredoc;
2926 0           @heredoc = ();
2927              
2928             # skip here document
2929 0           for my $heredoc_delimiter (@heredoc_delimiter) {
2930 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
2931             }
2932 0           @heredoc_delimiter = ();
2933              
2934 0           $here_script = '';
2935             }
2936 0           return "\n" . $heredoc;
2937             }
2938              
2939             # ignore space, comment
2940 0           elsif (/\G (\s+|\#.*) /oxgc) { return $1; }
2941              
2942             # if (, elsif (, unless (, while (, until (, given (, and when (
2943              
2944             # given, when
2945              
2946             # P.225 The given Statement
2947             # in Chapter 15: Smart Matching and given-when
2948             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
2949              
2950             # P.133 The given Statement
2951             # in Chapter 4: Statements and Declarations
2952             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2953              
2954             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) \s* \( ) /oxgc) {
2955 0           $slash = 'm//';
2956 0           return $1;
2957             }
2958              
2959             # scalar variable ($scalar = ...) =~ tr///;
2960             # scalar variable ($scalar = ...) =~ s///;
2961              
2962             # state
2963              
2964             # P.68 Persistent, Private Variables
2965             # in Chapter 4: Subroutines
2966             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
2967              
2968             # P.160 Persistent Lexically Scoped Variables: state
2969             # in Chapter 4: Statements and Declarations
2970             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2971              
2972             # (and so on)
2973              
2974             elsif (/\G ( \( \s* (?: local \b | my \b | our \b | state \b )? \s* \$ $qq_scalar ) /oxgc) {
2975 0           my $e_string = e_string($1);
2976              
2977 0 0         if (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
2978 0           $tr_variable = $e_string . e_string($1);
2979 0           $bind_operator = $2;
2980 0           $slash = 'm//';
2981 0           return '';
2982             }
2983             elsif (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
2984 0           $sub_variable = $e_string . e_string($1);
2985 0           $bind_operator = $2;
2986 0           $slash = 'm//';
2987 0           return '';
2988             }
2989             else {
2990 0           $slash = 'div';
2991 0           return $e_string;
2992             }
2993             }
2994              
2995             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
2996             elsif (/\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
2997 0           $slash = 'div';
2998 0           return q{Char::Eusascii::PREMATCH()};
2999             }
3000              
3001             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
3002             elsif (/\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
3003 0           $slash = 'div';
3004 0           return q{Char::Eusascii::MATCH()};
3005             }
3006              
3007             # $', ${'} --> $', ${'}
3008             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3009 0           $slash = 'div';
3010 0           return $1;
3011             }
3012              
3013             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
3014             elsif (/\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
3015 0           $slash = 'div';
3016 0           return q{Char::Eusascii::POSTMATCH()};
3017             }
3018              
3019             # scalar variable $scalar =~ tr///;
3020             # scalar variable $scalar =~ s///;
3021             # substr() =~ tr///;
3022             # substr() =~ s///;
3023             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3024 0           my $scalar = e_string($1);
3025              
3026 0 0         if (/\G ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3027 0           $tr_variable = $scalar;
3028 0           $bind_operator = $1;
3029 0           $slash = 'm//';
3030 0           return '';
3031             }
3032             elsif (/\G ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3033 0           $sub_variable = $scalar;
3034 0           $bind_operator = $1;
3035 0           $slash = 'm//';
3036 0           return '';
3037             }
3038             else {
3039 0           $slash = 'div';
3040 0           return $scalar;
3041             }
3042             }
3043              
3044             # end of statement
3045             elsif (/\G ( [,;] ) /oxgc) {
3046 0           $slash = 'm//';
3047              
3048             # clear tr/// variable
3049 0           $tr_variable = '';
3050              
3051             # clear s/// variable
3052 0           $sub_variable = '';
3053              
3054 0           $bind_operator = '';
3055              
3056 0           return $1;
3057             }
3058              
3059             # bareword
3060             elsif (/\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
3061 0           return $1;
3062             }
3063              
3064             # $0 --> $0
3065             elsif (/\G ( \$ 0 ) /oxmsgc) {
3066 0           $slash = 'div';
3067 0           return $1;
3068             }
3069             elsif (/\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
3070 0           $slash = 'div';
3071 0           return $1;
3072             }
3073              
3074             # $$ --> $$
3075             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3076 0           $slash = 'div';
3077 0           return $1;
3078             }
3079              
3080             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3081             # $1, $2, $3 --> $1, $2, $3 otherwise
3082             elsif (/\G \$ ([1-9][0-9]*) /oxmsgc) {
3083 0           $slash = 'div';
3084 0           return e_capture($1);
3085             }
3086             elsif (/\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
3087 0           $slash = 'div';
3088 0           return e_capture($1);
3089             }
3090              
3091             # $$foo[ ... ] --> $ $foo->[ ... ]
3092             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
3093 0           $slash = 'div';
3094 0           return e_capture($1.'->'.$2);
3095             }
3096              
3097             # $$foo{ ... } --> $ $foo->{ ... }
3098             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
3099 0           $slash = 'div';
3100 0           return e_capture($1.'->'.$2);
3101             }
3102              
3103             # $$foo
3104             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
3105 0           $slash = 'div';
3106 0           return e_capture($1);
3107             }
3108              
3109             # ${ foo }
3110             elsif (/\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
3111 0           $slash = 'div';
3112 0           return '${' . $1 . '}';
3113             }
3114              
3115             # ${ ... }
3116             elsif (/\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
3117 0           $slash = 'div';
3118 0           return e_capture($1);
3119             }
3120              
3121             # variable or function
3122             # $ @ % & * $ #
3123             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) {
3124 0           $slash = 'div';
3125 0           return $1;
3126             }
3127             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3128             # $ @ # \ ' " / ? ( ) [ ] < >
3129             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3130 0           $slash = 'div';
3131 0           return $1;
3132             }
3133              
3134             # while ()
3135             elsif (/\G \b (while \s* \( \s* <[\$]?[A-Za-z_][A-Za-z_0-9]*> \s* \)) \b /oxgc) {
3136 0           return $1;
3137             }
3138              
3139             # while () --- glob
3140              
3141             # avoid "Error: Runtime exception" of perl version 5.005_03
3142              
3143             elsif (/\G \b while \s* \( \s* < ((?:[^>\0\a\e\f\n\r\t])+?) > \s* \) \b /oxgc) {
3144 0           return 'while ($_ = Char::Eusascii::glob("' . $1 . '"))';
3145             }
3146              
3147             # while (glob)
3148             elsif (/\G \b while \s* \( \s* glob \s* \) /oxgc) {
3149 0           return 'while ($_ = Char::Eusascii::glob_)';
3150             }
3151              
3152             # while (glob(WILDCARD))
3153             elsif (/\G \b while \s* \( \s* glob \b /oxgc) {
3154 0           return 'while ($_ = Char::Eusascii::glob';
3155             }
3156              
3157             # doit if, doit unless, doit while, doit until, doit for, doit when
3158 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3159              
3160             # subroutines of package Char::Eusascii
3161 0           elsif (/\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3162 0           elsif (/\G \b Char::USASCII::eval (?= \s* \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3163 0           elsif (/\G \b Char::USASCII::eval \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'eval Char::USASCII::escape'; }
  0            
3164 0           elsif (/\G \b bytes::substr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3165 0           elsif (/\G \b chop \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::chop'; }
  0            
3166 0           elsif (/\G \b bytes::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3167 0           elsif (/\G \b Char::USASCII::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::USASCII::index'; }
  0            
3168 0           elsif (/\G \b index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::index'; }
  0            
3169 0           elsif (/\G \b bytes::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3170 0           elsif (/\G \b Char::USASCII::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::USASCII::rindex'; }
  0            
3171 0           elsif (/\G \b rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::rindex'; }
  0            
3172 0           elsif (/\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::lc'; }
  0            
3173 0           elsif (/\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::lcfirst'; }
  0            
3174 0           elsif (/\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::uc'; }
  0            
3175 0           elsif (/\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::ucfirst'; }
  0            
3176 0           elsif (/\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::fc'; }
  0            
3177              
3178             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3179 0           elsif (/\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3180 0           elsif (/\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3181 0           elsif (/\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3182 0           elsif (/\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3183 0           elsif (/\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3184 0           elsif (/\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3185 0           elsif (/\G -s \s+ qq \s* (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3186              
3187 0           elsif (/\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3188 0           elsif (/\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3189 0           elsif (/\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3190 0           elsif (/\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3191 0           elsif (/\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3192 0           elsif (/\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3193 0           elsif (/\G -s \s+ q \s* (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3194              
3195             elsif (/\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3196 0           { $slash = 'm//'; return "-s $1"; }
  0            
3197 0           elsif (/\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3198 0           elsif (/\G -s (?= \s+ [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3199 0           elsif (/\G -s \s+ (\w+) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3200              
3201 0           elsif (/\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3202 0           elsif (/\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3203 0           elsif (/\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::chr'; }
  0            
3204 0           elsif (/\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3205 0           elsif (/\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3206 0           elsif (/\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::glob'; }
  0            
3207 0           elsif (/\G \b lc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::lc_'; }
  0            
3208 0           elsif (/\G \b lcfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::lcfirst_'; }
  0            
3209 0           elsif (/\G \b uc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::uc_'; }
  0            
3210 0           elsif (/\G \b ucfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::ucfirst_'; }
  0            
3211 0           elsif (/\G \b fc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::fc_'; }
  0            
3212 0           elsif (/\G -s \b (?! \s* => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3213              
3214 0           elsif (/\G \b bytes::length \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3215 0           elsif (/\G \b bytes::chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3216 0           elsif (/\G \b chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::chr_'; }
  0            
3217 0           elsif (/\G \b bytes::ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3218 0           elsif (/\G \b ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3219 0           elsif (/\G \b glob \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Eusascii::glob_'; }
  0            
3220 0           elsif (/\G \b reverse \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3221 0           elsif (/\G \b getc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3222             # split
3223             elsif (/\G \b (split) \b (?! \s* => ) /oxgc) {
3224 0           $slash = 'm//';
3225              
3226 0           my $e = '';
3227 0           while (/\G ( \s+ | \( | \#.* ) /oxgc) {
3228 0           $e .= $1;
3229             }
3230              
3231             # end of split
3232 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Eusascii::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3233              
3234             # split scalar value
3235 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Char::Eusascii::split' . $e . e_string($1); }
3236              
3237             # split literal space
3238 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Char::Eusascii::split' . $e . qq {qq$1 $2}; }
3239 0           elsif (/\G \b qq (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; }
3240 0           elsif (/\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; }
3241 0           elsif (/\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; }
3242 0           elsif (/\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; }
3243 0           elsif (/\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; }
3244 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Char::Eusascii::split' . $e . qq {q$1 $2}; }
3245 0           elsif (/\G \b q (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; }
3246 0           elsif (/\G \b q (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; }
3247 0           elsif (/\G \b q (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; }
3248 0           elsif (/\G \b q (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; }
3249 0           elsif (/\G \b q (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; }
3250 0           elsif (/\G ' [ ] ' /oxgc) { return 'Char::Eusascii::split' . $e . qq {' '}; }
3251 0           elsif (/\G " [ ] " /oxgc) { return 'Char::Eusascii::split' . $e . qq {" "}; }
3252              
3253             # split qq//
3254             elsif (/\G \b (qq) \b /oxgc) {
3255 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3256             else {
3257 0           while (not /\G \z/oxgc) {
3258 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3259 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3260 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3261 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3262 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3263 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3264 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3265             }
3266 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3267             }
3268             }
3269              
3270             # split qr//
3271             elsif (/\G \b (qr) \b /oxgc) {
3272 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3273             else {
3274 0           while (not /\G \z/oxgc) {
3275 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3276 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3277 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3278 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3279 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3280 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3281 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3282 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3283             }
3284 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3285             }
3286             }
3287              
3288             # split q//
3289             elsif (/\G \b (q) \b /oxgc) {
3290 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
3291             else {
3292 0           while (not /\G \z/oxgc) {
3293 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3294 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3295 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3296 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3297 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3298 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3299 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3300             }
3301 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3302             }
3303             }
3304              
3305             # split m//
3306             elsif (/\G \b (m) \b /oxgc) {
3307 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3308             else {
3309 0           while (not /\G \z/oxgc) {
3310 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3311 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3312 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3313 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3314 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3315 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3316 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3317 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3318             }
3319 0           die __FILE__, ": Search pattern not terminated";
3320             }
3321             }
3322              
3323             # split ''
3324             elsif (/\G (\') /oxgc) {
3325 0           my $q_string = '';
3326 0           while (not /\G \z/oxgc) {
3327 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3328 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3329 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3330 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3331             }
3332 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3333             }
3334              
3335             # split ""
3336             elsif (/\G (\") /oxgc) {
3337 0           my $qq_string = '';
3338 0           while (not /\G \z/oxgc) {
3339 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3340 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3341 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3342 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3343             }
3344 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3345             }
3346              
3347             # split //
3348             elsif (/\G (\/) /oxgc) {
3349 0           my $regexp = '';
3350 0           while (not /\G \z/oxgc) {
3351 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3352 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3353 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3354 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3355             }
3356 0           die __FILE__, ": Search pattern not terminated";
3357             }
3358             }
3359              
3360             # tr/// or y///
3361              
3362             # about [cdsrbB]* (/B modifier)
3363             #
3364             # P.559 appendix C
3365             # of ISBN 4-89052-384-7 Programming perl
3366             # (Japanese title is: Perl puroguramingu)
3367              
3368             elsif (/\G \b ( tr | y ) \b /oxgc) {
3369 0           my $ope = $1;
3370              
3371             # $1 $2 $3 $4 $5 $6
3372 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3373 0           my @tr = ($tr_variable,$2);
3374 0           return e_tr(@tr,'',$4,$6);
3375             }
3376             else {
3377 0           my $e = '';
3378 0           while (not /\G \z/oxgc) {
3379 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3380             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3381 0           my @tr = ($tr_variable,$2);
3382 0           while (not /\G \z/oxgc) {
3383 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3384 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3385 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3386 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3387 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3388 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3389             }
3390 0           die __FILE__, ": Transliteration replacement not terminated";
3391             }
3392             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3393 0           my @tr = ($tr_variable,$2);
3394 0           while (not /\G \z/oxgc) {
3395 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3396 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3397 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3398 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3399 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3400 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3401             }
3402 0           die __FILE__, ": Transliteration replacement not terminated";
3403             }
3404             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3405 0           my @tr = ($tr_variable,$2);
3406 0           while (not /\G \z/oxgc) {
3407 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3408 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3409 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3410 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3411 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3412 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3413             }
3414 0           die __FILE__, ": Transliteration replacement not terminated";
3415             }
3416             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3417 0           my @tr = ($tr_variable,$2);
3418 0           while (not /\G \z/oxgc) {
3419 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3420 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3421 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3422 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3423 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3424 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3425             }
3426 0           die __FILE__, ": Transliteration replacement not terminated";
3427             }
3428             # $1 $2 $3 $4 $5 $6
3429             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3430 0           my @tr = ($tr_variable,$2);
3431 0           return e_tr(@tr,'',$4,$6);
3432             }
3433             }
3434 0           die __FILE__, ": Transliteration pattern not terminated";
3435             }
3436             }
3437              
3438             # qq//
3439             elsif (/\G \b (qq) \b /oxgc) {
3440 0           my $ope = $1;
3441              
3442             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3443 0 0         if (/\G (\#) /oxgc) { # qq# #
3444 0           my $qq_string = '';
3445 0           while (not /\G \z/oxgc) {
3446 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3447 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3448 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3449 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3450             }
3451 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3452             }
3453              
3454             else {
3455 0           my $e = '';
3456 0           while (not /\G \z/oxgc) {
3457 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3458              
3459             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3460             elsif (/\G (\() /oxgc) { # qq ( )
3461 0           my $qq_string = '';
3462 0           local $nest = 1;
3463 0           while (not /\G \z/oxgc) {
3464 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3465 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3466 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3467             elsif (/\G (\)) /oxgc) {
3468 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3469 0           else { $qq_string .= $1; }
3470             }
3471 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3472             }
3473 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3474             }
3475              
3476             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3477             elsif (/\G (\{) /oxgc) { # qq { }
3478 0           my $qq_string = '';
3479 0           local $nest = 1;
3480 0           while (not /\G \z/oxgc) {
3481 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3482 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3483 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3484             elsif (/\G (\}) /oxgc) {
3485 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3486 0           else { $qq_string .= $1; }
3487             }
3488 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3489             }
3490 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3491             }
3492              
3493             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3494             elsif (/\G (\[) /oxgc) { # qq [ ]
3495 0           my $qq_string = '';
3496 0           local $nest = 1;
3497 0           while (not /\G \z/oxgc) {
3498 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3499 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3500 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3501             elsif (/\G (\]) /oxgc) {
3502 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3503 0           else { $qq_string .= $1; }
3504             }
3505 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3506             }
3507 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3508             }
3509              
3510             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3511             elsif (/\G (\<) /oxgc) { # qq < >
3512 0           my $qq_string = '';
3513 0           local $nest = 1;
3514 0           while (not /\G \z/oxgc) {
3515 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3516 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3517 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3518             elsif (/\G (\>) /oxgc) {
3519 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3520 0           else { $qq_string .= $1; }
3521             }
3522 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3523             }
3524 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3525             }
3526              
3527             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3528             elsif (/\G (\S) /oxgc) { # qq * *
3529 0           my $delimiter = $1;
3530 0           my $qq_string = '';
3531 0           while (not /\G \z/oxgc) {
3532 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3533 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3534 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3535 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3536             }
3537 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3538             }
3539             }
3540 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3541             }
3542             }
3543              
3544             # qr//
3545             elsif (/\G \b (qr) \b /oxgc) {
3546 0           my $ope = $1;
3547 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { # qr# # #
3548 0           return e_qr($ope,$1,$3,$2,$4);
3549             }
3550             else {
3551 0           my $e = '';
3552 0           while (not /\G \z/oxgc) {
3553 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3554 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3555 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3556 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3557 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3558 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3559 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3560 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3561             }
3562 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3563             }
3564             }
3565              
3566             # qw//
3567             elsif (/\G \b (qw) \b /oxgc) {
3568 0           my $ope = $1;
3569 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3570 0           return e_qw($ope,$1,$3,$2);
3571             }
3572             else {
3573 0           my $e = '';
3574 0           while (not /\G \z/oxgc) {
3575 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3576              
3577 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3578 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3579              
3580 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3581 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3582              
3583 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3584 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3585              
3586 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3587 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3588              
3589 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3590 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3591             }
3592 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3593             }
3594             }
3595              
3596             # qx//
3597             elsif (/\G \b (qx) \b /oxgc) {
3598 0           my $ope = $1;
3599 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3600 0           return e_qq($ope,$1,$3,$2);
3601             }
3602             else {
3603 0           my $e = '';
3604 0           while (not /\G \z/oxgc) {
3605 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3606 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3607 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3608 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3609 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3610 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3611 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3612             }
3613 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3614             }
3615             }
3616              
3617             # q//
3618             elsif (/\G \b (q) \b /oxgc) {
3619 0           my $ope = $1;
3620              
3621             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3622              
3623             # avoid "Error: Runtime exception" of perl version 5.005_03
3624             # (and so on)
3625              
3626 0 0         if (/\G (\#) /oxgc) { # q# #
3627 0           my $q_string = '';
3628 0           while (not /\G \z/oxgc) {
3629 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3630 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3631 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3632 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3633             }
3634 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3635             }
3636              
3637             else {
3638 0           my $e = '';
3639 0           while (not /\G \z/oxgc) {
3640 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3641              
3642             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3643             elsif (/\G (\() /oxgc) { # q ( )
3644 0           my $q_string = '';
3645 0           local $nest = 1;
3646 0           while (not /\G \z/oxgc) {
3647 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3648 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3649 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3650 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3651             elsif (/\G (\)) /oxgc) {
3652 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3653 0           else { $q_string .= $1; }
3654             }
3655 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3656             }
3657 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3658             }
3659              
3660             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3661             elsif (/\G (\{) /oxgc) { # q { }
3662 0           my $q_string = '';
3663 0           local $nest = 1;
3664 0           while (not /\G \z/oxgc) {
3665 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3666 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3667 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3668 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
3669             elsif (/\G (\}) /oxgc) {
3670 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
3671 0           else { $q_string .= $1; }
3672             }
3673 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3674             }
3675 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3676             }
3677              
3678             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3679             elsif (/\G (\[) /oxgc) { # q [ ]
3680 0           my $q_string = '';
3681 0           local $nest = 1;
3682 0           while (not /\G \z/oxgc) {
3683 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3684 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3685 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3686 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
3687             elsif (/\G (\]) /oxgc) {
3688 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
3689 0           else { $q_string .= $1; }
3690             }
3691 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3692             }
3693 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3694             }
3695              
3696             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3697             elsif (/\G (\<) /oxgc) { # q < >
3698 0           my $q_string = '';
3699 0           local $nest = 1;
3700 0           while (not /\G \z/oxgc) {
3701 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3702 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3703 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3704 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
3705             elsif (/\G (\>) /oxgc) {
3706 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
3707 0           else { $q_string .= $1; }
3708             }
3709 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3710             }
3711 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3712             }
3713              
3714             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3715             elsif (/\G (\S) /oxgc) { # q * *
3716 0           my $delimiter = $1;
3717 0           my $q_string = '';
3718 0           while (not /\G \z/oxgc) {
3719 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3720 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3721 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3722 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3723             }
3724 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3725             }
3726             }
3727 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3728             }
3729             }
3730              
3731             # m//
3732             elsif (/\G \b (m) \b /oxgc) {
3733 0           my $ope = $1;
3734 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { # m# #
3735 0           return e_qr($ope,$1,$3,$2,$4);
3736             }
3737             else {
3738 0           my $e = '';
3739 0           while (not /\G \z/oxgc) {
3740 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3741 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3742 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3743 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3744 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3745 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3746 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3747 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3748 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3749             }
3750 0           die __FILE__, ": Search pattern not terminated";
3751             }
3752             }
3753              
3754             # s///
3755              
3756             # about [cegimosxpradlubB]* (/cg modifier)
3757             #
3758             # P.67 Pattern-Matching Operators
3759             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3760              
3761             elsif (/\G \b (s) \b /oxgc) {
3762 0           my $ope = $1;
3763              
3764             # $1 $2 $3 $4 $5 $6
3765 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlubB]*) /oxgc) { # s# # #
3766 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3767             }
3768             else {
3769 0           my $e = '';
3770 0           while (not /\G \z/oxgc) {
3771 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3772             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3773 0           my @s = ($1,$2,$3);
3774 0           while (not /\G \z/oxgc) {
3775 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3776             # $1 $2 $3 $4
3777 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3778 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3779 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3780 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3781 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3782 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3783 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3784 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3785 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3786             }
3787 0           die __FILE__, ": Substitution replacement not terminated";
3788             }
3789             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3790 0           my @s = ($1,$2,$3);
3791 0           while (not /\G \z/oxgc) {
3792 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3793             # $1 $2 $3 $4
3794 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3795 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3796 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3797 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3798 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3799 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3800 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3801 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3802 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3803             }
3804 0           die __FILE__, ": Substitution replacement not terminated";
3805             }
3806             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3807 0           my @s = ($1,$2,$3);
3808 0           while (not /\G \z/oxgc) {
3809 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3810             # $1 $2 $3 $4
3811 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3812 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3813 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3814 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3815 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3816 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3817 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3818             }
3819 0           die __FILE__, ": Substitution replacement not terminated";
3820             }
3821             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3822 0           my @s = ($1,$2,$3);
3823 0           while (not /\G \z/oxgc) {
3824 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3825             # $1 $2 $3 $4
3826 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3827 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3828 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3829 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3830 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3831 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3832 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3833 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3834 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3835             }
3836 0           die __FILE__, ": Substitution replacement not terminated";
3837             }
3838             # $1 $2 $3 $4 $5 $6
3839             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) {
3840 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3841             }
3842             # $1 $2 $3 $4 $5 $6
3843             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3844 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3845             }
3846             # $1 $2 $3 $4 $5 $6
3847             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3848 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3849             }
3850             # $1 $2 $3 $4 $5 $6
3851             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3852 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3853             }
3854             }
3855 0           die __FILE__, ": Substitution pattern not terminated";
3856             }
3857             }
3858              
3859             # require ignore module
3860 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3861 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3862 0           elsif (/\G \b require (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3863              
3864             # use strict; --> use strict; no strict qw(refs);
3865 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3866 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
3867 0           elsif (/\G \b use (\s+ strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
3868              
3869             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
3870             elsif (/\G \b use \s+ (([1-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
3871 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
3872 0           return "use $1; no strict qw(refs);";
3873             }
3874             else {
3875 0           return "use $1;";
3876             }
3877             }
3878             elsif (/\G \b use \s+ (v([0-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
3879 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
3880 0           return "use $1; no strict qw(refs);";
3881             }
3882             else {
3883 0           return "use $1;";
3884             }
3885             }
3886              
3887             # ignore use module
3888 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
3889 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
3890 0           elsif (/\G \b use (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
3891              
3892             # ignore no module
3893 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
3894 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
3895 0           elsif (/\G \b no (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
3896              
3897             # use else
3898 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
3899              
3900             # use else
3901 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
3902              
3903             # ''
3904             elsif (/\G (?
3905 0           my $q_string = '';
3906 0           while (not /\G \z/oxgc) {
3907 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3908 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
3909 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
3910 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3911             }
3912 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3913             }
3914              
3915             # ""
3916             elsif (/\G (\") /oxgc) {
3917 0           my $qq_string = '';
3918 0           while (not /\G \z/oxgc) {
3919 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3920 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
3921 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
3922 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3923             }
3924 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3925             }
3926              
3927             # ``
3928             elsif (/\G (\`) /oxgc) {
3929 0           my $qx_string = '';
3930 0           while (not /\G \z/oxgc) {
3931 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
3932 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
3933 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
3934 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
3935             }
3936 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3937             }
3938              
3939             # // --- not divide operator (num / num), not defined-or
3940             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
3941 0           my $regexp = '';
3942 0           while (not /\G \z/oxgc) {
3943 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3944 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
3945 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
3946 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3947             }
3948 0           die __FILE__, ": Search pattern not terminated";
3949             }
3950              
3951             # ?? --- not conditional operator (condition ? then : else)
3952             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
3953 0           my $regexp = '';
3954 0           while (not /\G \z/oxgc) {
3955 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3956 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
3957 0           elsif (/\G \? ([cgimosxpadlubB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
3958 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3959             }
3960 0           die __FILE__, ": Search pattern not terminated";
3961             }
3962              
3963             # << (bit shift) --- not here document
3964 0           elsif (/\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
3965              
3966             # <<'HEREDOC'
3967             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
3968 0           $slash = 'm//';
3969 0           my $here_quote = $1;
3970 0           my $delimiter = $2;
3971              
3972             # get here document
3973 0 0         if ($here_script eq '') {
3974 0           $here_script = CORE::substr $_, pos $_;
3975 0           $here_script =~ s/.*?\n//oxm;
3976             }
3977 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
3978 0           push @heredoc, $1 . qq{\n$delimiter\n};
3979 0           push @heredoc_delimiter, $delimiter;
3980             }
3981             else {
3982 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
3983             }
3984 0           return $here_quote;
3985             }
3986              
3987             # <<\HEREDOC
3988              
3989             # P.66 2.6.6. "Here" Documents
3990             # in Chapter 2: Bits and Pieces
3991             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3992              
3993             # P.73 "Here" Documents
3994             # in Chapter 2: Bits and Pieces
3995             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3996              
3997             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
3998 0           $slash = 'm//';
3999 0           my $here_quote = $1;
4000 0           my $delimiter = $2;
4001              
4002             # get here document
4003 0 0         if ($here_script eq '') {
4004 0           $here_script = CORE::substr $_, pos $_;
4005 0           $here_script =~ s/.*?\n//oxm;
4006             }
4007 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4008 0           push @heredoc, $1 . qq{\n$delimiter\n};
4009 0           push @heredoc_delimiter, $delimiter;
4010             }
4011             else {
4012 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4013             }
4014 0           return $here_quote;
4015             }
4016              
4017             # <<"HEREDOC"
4018             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4019 0           $slash = 'm//';
4020 0           my $here_quote = $1;
4021 0           my $delimiter = $2;
4022              
4023             # get here document
4024 0 0         if ($here_script eq '') {
4025 0           $here_script = CORE::substr $_, pos $_;
4026 0           $here_script =~ s/.*?\n//oxm;
4027             }
4028 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4029 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4030 0           push @heredoc_delimiter, $delimiter;
4031             }
4032             else {
4033 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4034             }
4035 0           return $here_quote;
4036             }
4037              
4038             # <
4039             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4040 0           $slash = 'm//';
4041 0           my $here_quote = $1;
4042 0           my $delimiter = $2;
4043              
4044             # get here document
4045 0 0         if ($here_script eq '') {
4046 0           $here_script = CORE::substr $_, pos $_;
4047 0           $here_script =~ s/.*?\n//oxm;
4048             }
4049 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4050 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4051 0           push @heredoc_delimiter, $delimiter;
4052             }
4053             else {
4054 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4055             }
4056 0           return $here_quote;
4057             }
4058              
4059             # <<`HEREDOC`
4060             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4061 0           $slash = 'm//';
4062 0           my $here_quote = $1;
4063 0           my $delimiter = $2;
4064              
4065             # get here document
4066 0 0         if ($here_script eq '') {
4067 0           $here_script = CORE::substr $_, pos $_;
4068 0           $here_script =~ s/.*?\n//oxm;
4069             }
4070 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4071 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4072 0           push @heredoc_delimiter, $delimiter;
4073             }
4074             else {
4075 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4076             }
4077 0           return $here_quote;
4078             }
4079              
4080             # <<= <=> <= < operator
4081             elsif (/\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4082 0           return $1;
4083             }
4084              
4085             #
4086             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4087 0           return $1;
4088             }
4089              
4090             # --- glob
4091              
4092             # avoid "Error: Runtime exception" of perl version 5.005_03
4093              
4094             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4095 0           return 'Char::Eusascii::glob("' . $1 . '")';
4096             }
4097              
4098             # __DATA__
4099 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4100              
4101             # __END__
4102 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4103              
4104             # \cD Control-D
4105              
4106             # P.68 2.6.8. Other Literal Tokens
4107             # in Chapter 2: Bits and Pieces
4108             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4109              
4110             # P.76 Other Literal Tokens
4111             # in Chapter 2: Bits and Pieces
4112             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4113              
4114 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4115              
4116             # \cZ Control-Z
4117 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4118              
4119             # any operator before div
4120             elsif (/\G (
4121             -- | \+\+ |
4122             [\)\}\]]
4123              
4124 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4125              
4126             # yada-yada or triple-dot operator
4127             elsif (/\G (
4128             \.\.\.
4129              
4130 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4131              
4132             # any operator before m//
4133              
4134             # //, //= (defined-or)
4135              
4136             # P.164 Logical Operators
4137             # in Chapter 10: More Control Structures
4138             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4139              
4140             # P.119 C-Style Logical (Short-Circuit) Operators
4141             # in Chapter 3: Unary and Binary Operators
4142             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4143              
4144             # (and so on)
4145              
4146             # ~~
4147              
4148             # P.221 The Smart Match Operator
4149             # in Chapter 15: Smart Matching and given-when
4150             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4151              
4152             # P.112 Smartmatch Operator
4153             # in Chapter 3: Unary and Binary Operators
4154             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4155              
4156             # (and so on)
4157              
4158             elsif (/\G (
4159              
4160             !~~ | !~ | != | ! |
4161             %= | % |
4162             &&= | && | &= | & |
4163             -= | -> | - |
4164             :\s*= |
4165             : |
4166             <<= | <=> | <= | < |
4167             == | => | =~ | = |
4168             >>= | >> | >= | > |
4169             \*\*= | \*\* | \*= | \* |
4170             \+= | \+ |
4171             \.\. | \.= | \. |
4172             \/\/= | \/\/ |
4173             \/= | \/ |
4174             \? |
4175             \\ |
4176             \^= | \^ |
4177             \b x= |
4178             \|\|= | \|\| | \|= | \| |
4179             ~~ | ~ |
4180             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4181             \b(?: print )\b |
4182              
4183             [,;\(\{\[]
4184              
4185 0           ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4186              
4187             # other any character
4188 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4189              
4190             # system error
4191             else {
4192 0           die __FILE__, ": Oops, this shouldn't happen!";
4193             }
4194             }
4195              
4196             # escape US-ASCII string
4197             sub e_string {
4198 0     0 0   my($string) = @_;
4199 0           my $e_string = '';
4200              
4201 0           local $slash = 'm//';
4202              
4203             # P.1024 Appendix W.10 Multibyte Processing
4204             # of ISBN 1-56592-224-7 CJKV Information Processing
4205             # (and so on)
4206              
4207 0           my @char = $string =~ / \G (\\?(?:$q_char)) /oxmsg;
4208              
4209             # without { ... }
4210 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4211 0 0         if ($string !~ /<
4212 0           return $string;
4213             }
4214             }
4215              
4216             E_STRING_LOOP:
4217 0           while ($string !~ /\G \z/oxgc) {
4218 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          
    0          
    0          
4219             }
4220              
4221             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Char::Eusascii::PREMATCH()]}
4222 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
4223 0           $e_string .= q{Char::Eusascii::PREMATCH()};
4224 0           $slash = 'div';
4225             }
4226              
4227             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Char::Eusascii::MATCH()]}
4228             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
4229 0           $e_string .= q{Char::Eusascii::MATCH()};
4230 0           $slash = 'div';
4231             }
4232              
4233             # $', ${'} --> $', ${'}
4234             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4235 0           $e_string .= $1;
4236 0           $slash = 'div';
4237             }
4238              
4239             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Char::Eusascii::POSTMATCH()]}
4240             elsif ($string =~ /\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
4241 0           $e_string .= q{Char::Eusascii::POSTMATCH()};
4242 0           $slash = 'div';
4243             }
4244              
4245             # bareword
4246             elsif ($string =~ /\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
4247 0           $e_string .= $1;
4248 0           $slash = 'div';
4249             }
4250              
4251             # $0 --> $0
4252             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4253 0           $e_string .= $1;
4254 0           $slash = 'div';
4255             }
4256             elsif ($string =~ /\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
4257 0           $e_string .= $1;
4258 0           $slash = 'div';
4259             }
4260              
4261             # $$ --> $$
4262             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4263 0           $e_string .= $1;
4264 0           $slash = 'div';
4265             }
4266              
4267             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4268             # $1, $2, $3 --> $1, $2, $3 otherwise
4269             elsif ($string =~ /\G \$ ([1-9][0-9]*) /oxmsgc) {
4270 0           $e_string .= e_capture($1);
4271 0           $slash = 'div';
4272             }
4273             elsif ($string =~ /\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
4274 0           $e_string .= e_capture($1);
4275 0           $slash = 'div';
4276             }
4277              
4278             # $$foo[ ... ] --> $ $foo->[ ... ]
4279             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
4280 0           $e_string .= e_capture($1.'->'.$2);
4281 0           $slash = 'div';
4282             }
4283              
4284             # $$foo{ ... } --> $ $foo->{ ... }
4285             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
4286 0           $e_string .= e_capture($1.'->'.$2);
4287 0           $slash = 'div';
4288             }
4289              
4290             # $$foo
4291             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
4292 0           $e_string .= e_capture($1);
4293 0           $slash = 'div';
4294             }
4295              
4296             # ${ foo }
4297             elsif ($string =~ /\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
4298 0           $e_string .= '${' . $1 . '}';
4299 0           $slash = 'div';
4300             }
4301              
4302             # ${ ... }
4303             elsif ($string =~ /\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
4304 0           $e_string .= e_capture($1);
4305 0           $slash = 'div';
4306             }
4307              
4308             # variable or function
4309             # $ @ % & * $ #
4310             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) {
4311 0           $e_string .= $1;
4312 0           $slash = 'div';
4313             }
4314             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4315             # $ @ # \ ' " / ? ( ) [ ] < >
4316             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4317 0           $e_string .= $1;
4318 0           $slash = 'div';
4319             }
4320              
4321             # subroutines of package Char::Eusascii
4322 0           elsif ($string =~ /\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4323 0           elsif ($string =~ /\G \b Char::USASCII::eval (?= \s* \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4324 0           elsif ($string =~ /\G \b Char::USASCII::eval \b /oxgc) { $e_string .= 'eval Char::USASCII::escape'; $slash = 'm//'; }
  0            
4325 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4326 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Char::Eusascii::chop'; $slash = 'm//'; }
  0            
4327 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4328 0           elsif ($string =~ /\G \b Char::USASCII::index \b /oxgc) { $e_string .= 'Char::USASCII::index'; $slash = 'm//'; }
  0            
4329 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Char::Eusascii::index'; $slash = 'm//'; }
  0            
4330 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4331 0           elsif ($string =~ /\G \b Char::USASCII::rindex \b /oxgc) { $e_string .= 'Char::USASCII::rindex'; $slash = 'm//'; }
  0            
4332 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Char::Eusascii::rindex'; $slash = 'm//'; }
  0            
4333 0           elsif ($string =~ /\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::lc'; $slash = 'm//'; }
  0            
4334 0           elsif ($string =~ /\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::lcfirst'; $slash = 'm//'; }
  0            
4335 0           elsif ($string =~ /\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::uc'; $slash = 'm//'; }
  0            
4336 0           elsif ($string =~ /\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::ucfirst'; $slash = 'm//'; }
  0            
4337 0           elsif ($string =~ /\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::fc'; $slash = 'm//'; }
  0            
4338              
4339             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4340 0           elsif ($string =~ /\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4341 0           elsif ($string =~ /\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4342 0           elsif ($string =~ /\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4343 0           elsif ($string =~ /\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4344 0           elsif ($string =~ /\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4345 0           elsif ($string =~ /\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4346 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            
4347              
4348 0           elsif ($string =~ /\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4349 0           elsif ($string =~ /\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4350 0           elsif ($string =~ /\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4351 0           elsif ($string =~ /\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4352 0           elsif ($string =~ /\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4353 0           elsif ($string =~ /\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4354 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            
4355              
4356             elsif ($string =~ /\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
4357 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4358 0           elsif ($string =~ /\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4359 0           elsif ($string =~ /\G -s (?= \s+ [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4360 0           elsif ($string =~ /\G -s \s+ (\w+) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4361              
4362 0           elsif ($string =~ /\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4363 0           elsif ($string =~ /\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4364 0           elsif ($string =~ /\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::chr'; $slash = 'm//'; }
  0            
4365 0           elsif ($string =~ /\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4366 0           elsif ($string =~ /\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4367 0           elsif ($string =~ /\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Eusascii::glob'; $slash = 'm//'; }
  0            
4368 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Char::Eusascii::lc_'; $slash = 'm//'; }
  0            
4369 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Char::Eusascii::lcfirst_'; $slash = 'm//'; }
  0            
4370 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Char::Eusascii::uc_'; $slash = 'm//'; }
  0            
4371 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Char::Eusascii::ucfirst_'; $slash = 'm//'; }
  0            
4372 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Char::Eusascii::fc_'; $slash = 'm//'; }
  0            
4373 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4374              
4375 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4376 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4377 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Char::Eusascii::chr_'; $slash = 'm//'; }
  0            
4378 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4379 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4380 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Char::Eusascii::glob_'; $slash = 'm//'; }
  0            
4381 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4382 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4383             # split
4384             elsif ($string =~ /\G \b (split) \b (?! \s* => ) /oxgc) {
4385 0           $slash = 'm//';
4386              
4387 0           my $e = '';
4388 0           while ($string =~ /\G ( \s+ | \( | \#.* ) /oxgc) {
4389 0           $e .= $1;
4390             }
4391              
4392             # end of split
4393 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Eusascii::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4394              
4395             # split scalar value
4396 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4397              
4398             # split literal space
4399 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4400 0           elsif ($string =~ /\G \b qq (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4401 0           elsif ($string =~ /\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4402 0           elsif ($string =~ /\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4403 0           elsif ($string =~ /\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4404 0           elsif ($string =~ /\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4405 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4406 0           elsif ($string =~ /\G \b q (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4407 0           elsif ($string =~ /\G \b q (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4408 0           elsif ($string =~ /\G \b q (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4409 0           elsif ($string =~ /\G \b q (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4410 0           elsif ($string =~ /\G \b q (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4411 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4412 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Char::Eusascii::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4413              
4414             # split qq//
4415             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4416 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            
4417             else {
4418 0           while ($string !~ /\G \z/oxgc) {
4419 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4420 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4421 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4422 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4423 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4424 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4425 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            
4426             }
4427 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4428             }
4429             }
4430              
4431             # split qr//
4432             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4433 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            
4434             else {
4435 0           while ($string !~ /\G \z/oxgc) {
4436 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4437 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4438 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4439 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4440 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4441 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            
4442 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4443 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            
4444             }
4445 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4446             }
4447             }
4448              
4449             # split q//
4450             elsif ($string =~ /\G \b (q) \b /oxgc) {
4451 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            
4452             else {
4453 0           while ($string !~ /\G \z/oxgc) {
4454 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4455 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4456 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4457 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4458 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4459 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4460 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            
4461             }
4462 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4463             }
4464             }
4465              
4466             # split m//
4467             elsif ($string =~ /\G \b (m) \b /oxgc) {
4468 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            
4469             else {
4470 0           while ($string !~ /\G \z/oxgc) {
4471 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4472 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            
4473 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            
4474 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            
4475 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            
4476 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            
4477 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4478 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            
4479             }
4480 0           die __FILE__, ": Search pattern not terminated";
4481             }
4482             }
4483              
4484             # split ''
4485             elsif ($string =~ /\G (\') /oxgc) {
4486 0           my $q_string = '';
4487 0           while ($string !~ /\G \z/oxgc) {
4488 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4489 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4490 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4491 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4492             }
4493 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4494             }
4495              
4496             # split ""
4497             elsif ($string =~ /\G (\") /oxgc) {
4498 0           my $qq_string = '';
4499 0           while ($string !~ /\G \z/oxgc) {
4500 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4501 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4502 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4503 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4504             }
4505 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4506             }
4507              
4508             # split //
4509             elsif ($string =~ /\G (\/) /oxgc) {
4510 0           my $regexp = '';
4511 0           while ($string !~ /\G \z/oxgc) {
4512 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4513 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4514 0           elsif ($string =~ /\G \/ ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4515 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4516             }
4517 0           die __FILE__, ": Search pattern not terminated";
4518             }
4519             }
4520              
4521             # qq//
4522             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4523 0           my $ope = $1;
4524 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4525 0           $e_string .= e_qq($ope,$1,$3,$2);
4526             }
4527             else {
4528 0           my $e = '';
4529 0           while ($string !~ /\G \z/oxgc) {
4530 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4531 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4532 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4533 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4534 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4535 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4536             }
4537 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4538             }
4539             }
4540              
4541             # qx//
4542             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4543 0           my $ope = $1;
4544 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4545 0           $e_string .= e_qq($ope,$1,$3,$2);
4546             }
4547             else {
4548 0           my $e = '';
4549 0           while ($string !~ /\G \z/oxgc) {
4550 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4551 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4552 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4553 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4554 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4555 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4556 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4557             }
4558 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4559             }
4560             }
4561              
4562             # q//
4563             elsif ($string =~ /\G \b (q) \b /oxgc) {
4564 0           my $ope = $1;
4565 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4566 0           $e_string .= e_q($ope,$1,$3,$2);
4567             }
4568             else {
4569 0           my $e = '';
4570 0           while ($string !~ /\G \z/oxgc) {
4571 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4572 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4573 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4574 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4575 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4576 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            
4577             }
4578 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4579             }
4580             }
4581              
4582             # ''
4583 0           elsif ($string =~ /\G (?
4584              
4585             # ""
4586 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4587              
4588             # ``
4589 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4590              
4591             # <<= <=> <= < operator
4592             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc)
4593 0           { $e_string .= $1; }
4594              
4595             #
4596 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4597              
4598             # --- glob
4599             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4600 0           $e_string .= 'Char::Eusascii::glob("' . $1 . '")';
4601             }
4602              
4603             # << (bit shift) --- not here document
4604 0           elsif ($string =~ /\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4605              
4606             # <<'HEREDOC'
4607             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4608 0           $slash = 'm//';
4609 0           my $here_quote = $1;
4610 0           my $delimiter = $2;
4611              
4612             # get here document
4613 0 0         if ($here_script eq '') {
4614 0           $here_script = CORE::substr $_, pos $_;
4615 0           $here_script =~ s/.*?\n//oxm;
4616             }
4617 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4618 0           push @heredoc, $1 . qq{\n$delimiter\n};
4619 0           push @heredoc_delimiter, $delimiter;
4620             }
4621             else {
4622 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4623             }
4624 0           $e_string .= $here_quote;
4625             }
4626              
4627             # <<\HEREDOC
4628             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4629 0           $slash = 'm//';
4630 0           my $here_quote = $1;
4631 0           my $delimiter = $2;
4632              
4633             # get here document
4634 0 0         if ($here_script eq '') {
4635 0           $here_script = CORE::substr $_, pos $_;
4636 0           $here_script =~ s/.*?\n//oxm;
4637             }
4638 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4639 0           push @heredoc, $1 . qq{\n$delimiter\n};
4640 0           push @heredoc_delimiter, $delimiter;
4641             }
4642             else {
4643 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4644             }
4645 0           $e_string .= $here_quote;
4646             }
4647              
4648             # <<"HEREDOC"
4649             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4650 0           $slash = 'm//';
4651 0           my $here_quote = $1;
4652 0           my $delimiter = $2;
4653              
4654             # get here document
4655 0 0         if ($here_script eq '') {
4656 0           $here_script = CORE::substr $_, pos $_;
4657 0           $here_script =~ s/.*?\n//oxm;
4658             }
4659 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4660 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4661 0           push @heredoc_delimiter, $delimiter;
4662             }
4663             else {
4664 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4665             }
4666 0           $e_string .= $here_quote;
4667             }
4668              
4669             # <
4670             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4671 0           $slash = 'm//';
4672 0           my $here_quote = $1;
4673 0           my $delimiter = $2;
4674              
4675             # get here document
4676 0 0         if ($here_script eq '') {
4677 0           $here_script = CORE::substr $_, pos $_;
4678 0           $here_script =~ s/.*?\n//oxm;
4679             }
4680 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4681 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4682 0           push @heredoc_delimiter, $delimiter;
4683             }
4684             else {
4685 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4686             }
4687 0           $e_string .= $here_quote;
4688             }
4689              
4690             # <<`HEREDOC`
4691             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4692 0           $slash = 'm//';
4693 0           my $here_quote = $1;
4694 0           my $delimiter = $2;
4695              
4696             # get here document
4697 0 0         if ($here_script eq '') {
4698 0           $here_script = CORE::substr $_, pos $_;
4699 0           $here_script =~ s/.*?\n//oxm;
4700             }
4701 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4702 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4703 0           push @heredoc_delimiter, $delimiter;
4704             }
4705             else {
4706 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4707             }
4708 0           $e_string .= $here_quote;
4709             }
4710              
4711             # any operator before div
4712             elsif ($string =~ /\G (
4713             -- | \+\+ |
4714             [\)\}\]]
4715              
4716 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4717              
4718             # yada-yada or triple-dot operator
4719             elsif ($string =~ /\G (
4720             \.\.\.
4721              
4722 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4723              
4724             # any operator before m//
4725             elsif ($string =~ /\G (
4726              
4727             !~~ | !~ | != | ! |
4728             %= | % |
4729             &&= | && | &= | & |
4730             -= | -> | - |
4731             :\s*= |
4732             : |
4733             <<= | <=> | <= | < |
4734             == | => | =~ | = |
4735             >>= | >> | >= | > |
4736             \*\*= | \*\* | \*= | \* |
4737             \+= | \+ |
4738             \.\. | \.= | \. |
4739             \/\/= | \/\/ |
4740             \/= | \/ |
4741             \? |
4742             \\ |
4743             \^= | \^ |
4744             \b x= |
4745             \|\|= | \|\| | \|= | \| |
4746             ~~ | ~ |
4747             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4748             \b(?: print )\b |
4749              
4750             [,;\(\{\[]
4751              
4752 0           ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4753              
4754             # other any character
4755 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4756              
4757             # system error
4758             else {
4759 0           die __FILE__, ": Oops, this shouldn't happen!";
4760             }
4761             }
4762              
4763 0           return $e_string;
4764             }
4765              
4766             #
4767             # character class
4768             #
4769             sub character_class {
4770 0     0 0   my($char,$modifier) = @_;
4771              
4772 0 0         if ($char eq '.') {
4773 0 0         if ($modifier =~ /s/) {
4774 0           return '${Char::Eusascii::dot_s}';
4775             }
4776             else {
4777 0           return '${Char::Eusascii::dot}';
4778             }
4779             }
4780             else {
4781 0           return Char::Eusascii::classic_character_class($char);
4782             }
4783             }
4784              
4785             #
4786             # escape capture ($1, $2, $3, ...)
4787             #
4788             sub e_capture {
4789              
4790 0     0 0   return join '', '${', $_[0], '}';
4791             }
4792              
4793             #
4794             # escape transliteration (tr/// or y///)
4795             #
4796             sub e_tr {
4797 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4798 0           my $e_tr = '';
4799 0   0       $modifier ||= '';
4800              
4801 0           $slash = 'div';
4802              
4803             # quote character class 1
4804 0           $charclass = q_tr($charclass);
4805              
4806             # quote character class 2
4807 0           $charclass2 = q_tr($charclass2);
4808              
4809             # /b /B modifier
4810 0 0         if ($modifier =~ tr/bB//d) {
4811 0 0         if ($variable eq '') {
4812 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
4813             }
4814             else {
4815 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4816             }
4817             }
4818             else {
4819 0 0         if ($variable eq '') {
4820 0           $e_tr = qq{Char::Eusascii::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4821             }
4822             else {
4823 0           $e_tr = qq{Char::Eusascii::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4824             }
4825             }
4826              
4827             # clear tr/// variable
4828 0           $tr_variable = '';
4829 0           $bind_operator = '';
4830              
4831 0           return $e_tr;
4832             }
4833              
4834             #
4835             # quote for escape transliteration (tr/// or y///)
4836             #
4837             sub q_tr {
4838 0     0 0   my($charclass) = @_;
4839              
4840             # quote character class
4841 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4842 0           return e_q('', "'", "'", $charclass); # --> q' '
4843             }
4844             elsif ($charclass !~ /\//oxms) {
4845 0           return e_q('q', '/', '/', $charclass); # --> q/ /
4846             }
4847             elsif ($charclass !~ /\#/oxms) {
4848 0           return e_q('q', '#', '#', $charclass); # --> q# #
4849             }
4850             elsif ($charclass !~ /[\<\>]/oxms) {
4851 0           return e_q('q', '<', '>', $charclass); # --> q< >
4852             }
4853             elsif ($charclass !~ /[\(\)]/oxms) {
4854 0           return e_q('q', '(', ')', $charclass); # --> q( )
4855             }
4856             elsif ($charclass !~ /[\{\}]/oxms) {
4857 0           return e_q('q', '{', '}', $charclass); # --> q{ }
4858             }
4859             else {
4860 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
4861 0 0         if ($charclass !~ /\Q$char\E/xms) {
4862 0           return e_q('q', $char, $char, $charclass);
4863             }
4864             }
4865             }
4866              
4867 0           return e_q('q', '{', '}', $charclass);
4868             }
4869              
4870             #
4871             # escape q string (q//, '')
4872             #
4873             sub e_q {
4874 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
4875              
4876 0           $slash = 'div';
4877              
4878 0           return join '', $ope, $delimiter, $string, $end_delimiter;
4879             }
4880              
4881             #
4882             # escape qq string (qq//, "", qx//, ``)
4883             #
4884             sub e_qq {
4885 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
4886              
4887 0           $slash = 'div';
4888              
4889 0           my $left_e = 0;
4890 0           my $right_e = 0;
4891 0           my @char = $string =~ /\G(
4892             \\o\{ [0-7]+ \} |
4893             \\x\{ [0-9A-Fa-f]+ \} |
4894             \\N\{ [^0-9\}][^\}]* \} |
4895             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
4896             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
4897             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
4898             \$ \s* \d+ |
4899             \$ \s* \{ \s* \d+ \s* \} |
4900             \$ \$ (?![\w\{]) |
4901             \$ \s* \$ \s* $qq_variable |
4902             \\?(?:$q_char)
4903             )/oxmsg;
4904              
4905 0           for (my $i=0; $i <= $#char; $i++) {
4906              
4907             # "\L\u" --> "\u\L"
4908 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
4909 0           @char[$i,$i+1] = @char[$i+1,$i];
4910             }
4911              
4912             # "\U\l" --> "\l\U"
4913             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
4914 0           @char[$i,$i+1] = @char[$i+1,$i];
4915             }
4916              
4917             # octal escape sequence
4918             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
4919 0           $char[$i] = Char::Eusascii::octchr($1);
4920             }
4921              
4922             # hexadecimal escape sequence
4923             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
4924 0           $char[$i] = Char::Eusascii::hexchr($1);
4925             }
4926              
4927             # \N{CHARNAME} --> N{CHARNAME}
4928             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
4929 0           $char[$i] = $1;
4930             }
4931              
4932 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          
4933             }
4934              
4935             # \F
4936             #
4937             # P.69 Table 2-6. Translation escapes
4938             # in Chapter 2: Bits and Pieces
4939             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4940             # (and so on)
4941              
4942             # \u \l \U \L \F \Q \E
4943 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
4944 0 0         if ($right_e < $left_e) {
4945 0           $char[$i] = '\\' . $char[$i];
4946             }
4947             }
4948             elsif ($char[$i] eq '\u') {
4949              
4950             # "STRING @{[ LIST EXPR ]} MORE STRING"
4951              
4952             # P.257 Other Tricks You Can Do with Hard References
4953             # in Chapter 8: References
4954             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4955              
4956             # P.353 Other Tricks You Can Do with Hard References
4957             # in Chapter 8: References
4958             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4959              
4960             # (and so on)
4961              
4962 0           $char[$i] = '@{[Char::Eusascii::ucfirst qq<';
4963 0           $left_e++;
4964             }
4965             elsif ($char[$i] eq '\l') {
4966 0           $char[$i] = '@{[Char::Eusascii::lcfirst qq<';
4967 0           $left_e++;
4968             }
4969             elsif ($char[$i] eq '\U') {
4970 0           $char[$i] = '@{[Char::Eusascii::uc qq<';
4971 0           $left_e++;
4972             }
4973             elsif ($char[$i] eq '\L') {
4974 0           $char[$i] = '@{[Char::Eusascii::lc qq<';
4975 0           $left_e++;
4976             }
4977             elsif ($char[$i] eq '\F') {
4978 0           $char[$i] = '@{[Char::Eusascii::fc qq<';
4979 0           $left_e++;
4980             }
4981             elsif ($char[$i] eq '\Q') {
4982 0           $char[$i] = '@{[CORE::quotemeta qq<';
4983 0           $left_e++;
4984             }
4985             elsif ($char[$i] eq '\E') {
4986 0 0         if ($right_e < $left_e) {
4987 0           $char[$i] = '>]}';
4988 0           $right_e++;
4989             }
4990             else {
4991 0           $char[$i] = '';
4992             }
4993             }
4994             elsif ($char[$i] eq '\Q') {
4995 0           while (1) {
4996 0 0         if (++$i > $#char) {
4997 0           last;
4998             }
4999 0 0         if ($char[$i] eq '\E') {
5000 0           last;
5001             }
5002             }
5003             }
5004             elsif ($char[$i] eq '\E') {
5005             }
5006              
5007             # $0 --> $0
5008             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5009             }
5010             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5011             }
5012              
5013             # $$ --> $$
5014             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5015             }
5016              
5017             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5018             # $1, $2, $3 --> $1, $2, $3 otherwise
5019             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5020 0           $char[$i] = e_capture($1);
5021             }
5022             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5023 0           $char[$i] = e_capture($1);
5024             }
5025              
5026             # $$foo[ ... ] --> $ $foo->[ ... ]
5027             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5028 0           $char[$i] = e_capture($1.'->'.$2);
5029             }
5030              
5031             # $$foo{ ... } --> $ $foo->{ ... }
5032             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5033 0           $char[$i] = e_capture($1.'->'.$2);
5034             }
5035              
5036             # $$foo
5037             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5038 0           $char[$i] = e_capture($1);
5039             }
5040              
5041             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
5042             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5043 0           $char[$i] = '@{[Char::Eusascii::PREMATCH()]}';
5044             }
5045              
5046             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
5047             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5048 0           $char[$i] = '@{[Char::Eusascii::MATCH()]}';
5049             }
5050              
5051             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
5052             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5053 0           $char[$i] = '@{[Char::Eusascii::POSTMATCH()]}';
5054             }
5055              
5056             # ${ foo } --> ${ foo }
5057             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5058             }
5059              
5060             # ${ ... }
5061             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5062 0           $char[$i] = e_capture($1);
5063             }
5064             }
5065              
5066             # return string
5067 0 0         if ($left_e > $right_e) {
5068 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5069             }
5070 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5071             }
5072              
5073             #
5074             # escape qw string (qw//)
5075             #
5076             sub e_qw {
5077 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5078              
5079 0           $slash = 'div';
5080              
5081             # choice again delimiter
5082 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5083 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5084 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5085             }
5086             elsif (not $octet{')'}) {
5087 0           return join '', $ope, '(', $string, ')';
5088             }
5089             elsif (not $octet{'}'}) {
5090 0           return join '', $ope, '{', $string, '}';
5091             }
5092             elsif (not $octet{']'}) {
5093 0           return join '', $ope, '[', $string, ']';
5094             }
5095             elsif (not $octet{'>'}) {
5096 0           return join '', $ope, '<', $string, '>';
5097             }
5098             else {
5099 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5100 0 0         if (not $octet{$char}) {
5101 0           return join '', $ope, $char, $string, $char;
5102             }
5103             }
5104             }
5105              
5106             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5107 0           my @string = CORE::split(/\s+/, $string);
5108 0           for my $string (@string) {
5109 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5110 0           for my $octet (@octet) {
5111 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5112 0           $octet = '\\' . $1;
5113             }
5114             }
5115 0           $string = join '', @octet;
5116             }
5117 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5118             }
5119              
5120             #
5121             # escape here document (<<"HEREDOC", <
5122             #
5123             sub e_heredoc {
5124 0     0 0   my($string) = @_;
5125              
5126 0           $slash = 'm//';
5127              
5128 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5129              
5130 0           my $left_e = 0;
5131 0           my $right_e = 0;
5132 0           my @char = $string =~ /\G(
5133             \\o\{ [0-7]+ \} |
5134             \\x\{ [0-9A-Fa-f]+ \} |
5135             \\N\{ [^0-9\}][^\}]* \} |
5136             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5137             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5138             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5139             \$ \s* \d+ |
5140             \$ \s* \{ \s* \d+ \s* \} |
5141             \$ \$ (?![\w\{]) |
5142             \$ \s* \$ \s* $qq_variable |
5143             \\?(?:$q_char)
5144             )/oxmsg;
5145              
5146 0           for (my $i=0; $i <= $#char; $i++) {
5147              
5148             # "\L\u" --> "\u\L"
5149 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5150 0           @char[$i,$i+1] = @char[$i+1,$i];
5151             }
5152              
5153             # "\U\l" --> "\l\U"
5154             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5155 0           @char[$i,$i+1] = @char[$i+1,$i];
5156             }
5157              
5158             # octal escape sequence
5159             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5160 0           $char[$i] = Char::Eusascii::octchr($1);
5161             }
5162              
5163             # hexadecimal escape sequence
5164             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5165 0           $char[$i] = Char::Eusascii::hexchr($1);
5166             }
5167              
5168             # \N{CHARNAME} --> N{CHARNAME}
5169             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5170 0           $char[$i] = $1;
5171             }
5172              
5173 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          
5174             }
5175              
5176             # \u \l \U \L \F \Q \E
5177 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5178 0 0         if ($right_e < $left_e) {
5179 0           $char[$i] = '\\' . $char[$i];
5180             }
5181             }
5182             elsif ($char[$i] eq '\u') {
5183 0           $char[$i] = '@{[Char::Eusascii::ucfirst qq<';
5184 0           $left_e++;
5185             }
5186             elsif ($char[$i] eq '\l') {
5187 0           $char[$i] = '@{[Char::Eusascii::lcfirst qq<';
5188 0           $left_e++;
5189             }
5190             elsif ($char[$i] eq '\U') {
5191 0           $char[$i] = '@{[Char::Eusascii::uc qq<';
5192 0           $left_e++;
5193             }
5194             elsif ($char[$i] eq '\L') {
5195 0           $char[$i] = '@{[Char::Eusascii::lc qq<';
5196 0           $left_e++;
5197             }
5198             elsif ($char[$i] eq '\F') {
5199 0           $char[$i] = '@{[Char::Eusascii::fc qq<';
5200 0           $left_e++;
5201             }
5202             elsif ($char[$i] eq '\Q') {
5203 0           $char[$i] = '@{[CORE::quotemeta qq<';
5204 0           $left_e++;
5205             }
5206             elsif ($char[$i] eq '\E') {
5207 0 0         if ($right_e < $left_e) {
5208 0           $char[$i] = '>]}';
5209 0           $right_e++;
5210             }
5211             else {
5212 0           $char[$i] = '';
5213             }
5214             }
5215             elsif ($char[$i] eq '\Q') {
5216 0           while (1) {
5217 0 0         if (++$i > $#char) {
5218 0           last;
5219             }
5220 0 0         if ($char[$i] eq '\E') {
5221 0           last;
5222             }
5223             }
5224             }
5225             elsif ($char[$i] eq '\E') {
5226             }
5227              
5228             # $0 --> $0
5229             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5230             }
5231             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5232             }
5233              
5234             # $$ --> $$
5235             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5236             }
5237              
5238             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5239             # $1, $2, $3 --> $1, $2, $3 otherwise
5240             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5241 0           $char[$i] = e_capture($1);
5242             }
5243             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5244 0           $char[$i] = e_capture($1);
5245             }
5246              
5247             # $$foo[ ... ] --> $ $foo->[ ... ]
5248             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5249 0           $char[$i] = e_capture($1.'->'.$2);
5250             }
5251              
5252             # $$foo{ ... } --> $ $foo->{ ... }
5253             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5254 0           $char[$i] = e_capture($1.'->'.$2);
5255             }
5256              
5257             # $$foo
5258             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5259 0           $char[$i] = e_capture($1);
5260             }
5261              
5262             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
5263             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5264 0           $char[$i] = '@{[Char::Eusascii::PREMATCH()]}';
5265             }
5266              
5267             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
5268             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5269 0           $char[$i] = '@{[Char::Eusascii::MATCH()]}';
5270             }
5271              
5272             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
5273             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5274 0           $char[$i] = '@{[Char::Eusascii::POSTMATCH()]}';
5275             }
5276              
5277             # ${ foo } --> ${ foo }
5278             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5279             }
5280              
5281             # ${ ... }
5282             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5283 0           $char[$i] = e_capture($1);
5284             }
5285             }
5286              
5287             # return string
5288 0 0         if ($left_e > $right_e) {
5289 0           return join '', @char, '>]}' x ($left_e - $right_e);
5290             }
5291 0           return join '', @char;
5292             }
5293              
5294             #
5295             # escape regexp (m//, qr//)
5296             #
5297             sub e_qr {
5298 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5299 0   0       $modifier ||= '';
5300              
5301 0           $modifier =~ tr/p//d;
5302 0 0         if ($modifier =~ /([adlu])/oxms) {
5303 0           my $line = 0;
5304 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5305 0 0         if ($filename ne __FILE__) {
5306 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5307 0           last;
5308             }
5309             }
5310 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5311             }
5312              
5313 0           $slash = 'div';
5314              
5315             # literal null string pattern
5316 0 0         if ($string eq '') {
    0          
5317 0           $modifier =~ tr/bB//d;
5318 0           $modifier =~ tr/i//d;
5319 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5320             }
5321              
5322             # /b /B modifier
5323             elsif ($modifier =~ tr/bB//d) {
5324              
5325             # choice again delimiter
5326 0 0         if ($delimiter =~ / [\@:] /oxms) {
5327 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
5328 0           my %octet = map {$_ => 1} @char;
  0            
5329 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5330 0           $delimiter = '(';
5331 0           $end_delimiter = ')';
5332             }
5333             elsif (not $octet{'}'}) {
5334 0           $delimiter = '{';
5335 0           $end_delimiter = '}';
5336             }
5337             elsif (not $octet{']'}) {
5338 0           $delimiter = '[';
5339 0           $end_delimiter = ']';
5340             }
5341             elsif (not $octet{'>'}) {
5342 0           $delimiter = '<';
5343 0           $end_delimiter = '>';
5344             }
5345             else {
5346 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5347 0 0         if (not $octet{$char}) {
5348 0           $delimiter = $char;
5349 0           $end_delimiter = $char;
5350 0           last;
5351             }
5352             }
5353             }
5354             }
5355              
5356 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5357 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5358             }
5359             else {
5360 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5361             }
5362             }
5363              
5364 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5365 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5366              
5367             # split regexp
5368 0           my @char = $string =~ /\G(
5369             \\o\{ [0-7]+ \} |
5370             \\ [0-7]{2,3} |
5371             \\x\{ [0-9A-Fa-f]+ \} |
5372             \\x [0-9A-Fa-f]{1,2} |
5373             \\c [\x40-\x5F] |
5374             \\N\{ [^0-9\}][^\}]* \} |
5375             \\p\{ [^0-9\}][^\}]* \} |
5376             \\P\{ [^0-9\}][^\}]* \} |
5377             \\ (?:$q_char) |
5378             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5379             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5380             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5381             [\$\@] $qq_variable |
5382             \$ \s* \d+ |
5383             \$ \s* \{ \s* \d+ \s* \} |
5384             \$ \$ (?![\w\{]) |
5385             \$ \s* \$ \s* $qq_variable |
5386             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5387             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5388             \[\^ |
5389             \(\? |
5390             (?:$q_char)
5391             )/oxmsg;
5392              
5393             # choice again delimiter
5394 0 0         if ($delimiter =~ / [\@:] /oxms) {
5395 0           my %octet = map {$_ => 1} @char;
  0            
5396 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5397 0           $delimiter = '(';
5398 0           $end_delimiter = ')';
5399             }
5400             elsif (not $octet{'}'}) {
5401 0           $delimiter = '{';
5402 0           $end_delimiter = '}';
5403             }
5404             elsif (not $octet{']'}) {
5405 0           $delimiter = '[';
5406 0           $end_delimiter = ']';
5407             }
5408             elsif (not $octet{'>'}) {
5409 0           $delimiter = '<';
5410 0           $end_delimiter = '>';
5411             }
5412             else {
5413 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5414 0 0         if (not $octet{$char}) {
5415 0           $delimiter = $char;
5416 0           $end_delimiter = $char;
5417 0           last;
5418             }
5419             }
5420             }
5421             }
5422              
5423 0           my $left_e = 0;
5424 0           my $right_e = 0;
5425 0           for (my $i=0; $i <= $#char; $i++) {
5426              
5427             # "\L\u" --> "\u\L"
5428 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
5429 0           @char[$i,$i+1] = @char[$i+1,$i];
5430             }
5431              
5432             # "\U\l" --> "\l\U"
5433             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5434 0           @char[$i,$i+1] = @char[$i+1,$i];
5435             }
5436              
5437             # octal escape sequence
5438             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5439 0           $char[$i] = Char::Eusascii::octchr($1);
5440             }
5441              
5442             # hexadecimal escape sequence
5443             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5444 0           $char[$i] = Char::Eusascii::hexchr($1);
5445             }
5446              
5447             # \N{CHARNAME} --> N\{CHARNAME}
5448             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5449 0           $char[$i] = $1 . '\\' . $2;
5450             }
5451              
5452             # \p{PROPERTY} --> p\{PROPERTY}
5453             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5454 0           $char[$i] = $1 . '\\' . $2;
5455             }
5456              
5457             # \P{PROPERTY} --> P\{PROPERTY}
5458             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5459 0           $char[$i] = $1 . '\\' . $2;
5460             }
5461              
5462             # \p, \P, \X --> p, P, X
5463             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5464 0           $char[$i] = $1;
5465             }
5466              
5467 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          
5468             }
5469              
5470             # join separated multiple-octet
5471 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5472 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 (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
5473 0           $char[$i] .= join '', splice @char, $i+1, 3;
5474             }
5475             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
5476 0           $char[$i] .= join '', splice @char, $i+1, 2;
5477             }
5478             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
5479 0           $char[$i] .= join '', splice @char, $i+1, 1;
5480             }
5481             }
5482              
5483             # open character class [...]
5484             elsif ($char[$i] eq '[') {
5485 0           my $left = $i;
5486              
5487             # [] make die "Unmatched [] in regexp ..."
5488             # (and so on)
5489              
5490 0 0         if ($char[$i+1] eq ']') {
5491 0           $i++;
5492             }
5493              
5494 0           while (1) {
5495 0 0         if (++$i > $#char) {
5496 0           die __FILE__, ": Unmatched [] in regexp";
5497             }
5498 0 0         if ($char[$i] eq ']') {
5499 0           my $right = $i;
5500              
5501             # [...]
5502 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5503 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5504             }
5505             else {
5506 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
5507             }
5508              
5509 0           $i = $left;
5510 0           last;
5511             }
5512             }
5513             }
5514              
5515             # open character class [^...]
5516             elsif ($char[$i] eq '[^') {
5517 0           my $left = $i;
5518              
5519             # [^] make die "Unmatched [] in regexp ..."
5520             # (and so on)
5521              
5522 0 0         if ($char[$i+1] eq ']') {
5523 0           $i++;
5524             }
5525              
5526 0           while (1) {
5527 0 0         if (++$i > $#char) {
5528 0           die __FILE__, ": Unmatched [] in regexp";
5529             }
5530 0 0         if ($char[$i] eq ']') {
5531 0           my $right = $i;
5532              
5533             # [^...]
5534 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5535 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5536             }
5537             else {
5538 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5539             }
5540              
5541 0           $i = $left;
5542 0           last;
5543             }
5544             }
5545             }
5546              
5547             # rewrite character class or escape character
5548             elsif (my $char = character_class($char[$i],$modifier)) {
5549 0           $char[$i] = $char;
5550             }
5551              
5552             # /i modifier
5553             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
5554 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
5555 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
5556             }
5557             else {
5558 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
5559             }
5560             }
5561              
5562             # \u \l \U \L \F \Q \E
5563             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5564 0 0         if ($right_e < $left_e) {
5565 0           $char[$i] = '\\' . $char[$i];
5566             }
5567             }
5568             elsif ($char[$i] eq '\u') {
5569 0           $char[$i] = '@{[Char::Eusascii::ucfirst qq<';
5570 0           $left_e++;
5571             }
5572             elsif ($char[$i] eq '\l') {
5573 0           $char[$i] = '@{[Char::Eusascii::lcfirst qq<';
5574 0           $left_e++;
5575             }
5576             elsif ($char[$i] eq '\U') {
5577 0           $char[$i] = '@{[Char::Eusascii::uc qq<';
5578 0           $left_e++;
5579             }
5580             elsif ($char[$i] eq '\L') {
5581 0           $char[$i] = '@{[Char::Eusascii::lc qq<';
5582 0           $left_e++;
5583             }
5584             elsif ($char[$i] eq '\F') {
5585 0           $char[$i] = '@{[Char::Eusascii::fc qq<';
5586 0           $left_e++;
5587             }
5588             elsif ($char[$i] eq '\Q') {
5589 0           $char[$i] = '@{[CORE::quotemeta qq<';
5590 0           $left_e++;
5591             }
5592             elsif ($char[$i] eq '\E') {
5593 0 0         if ($right_e < $left_e) {
5594 0           $char[$i] = '>]}';
5595 0           $right_e++;
5596             }
5597             else {
5598 0           $char[$i] = '';
5599             }
5600             }
5601             elsif ($char[$i] eq '\Q') {
5602 0           while (1) {
5603 0 0         if (++$i > $#char) {
5604 0           last;
5605             }
5606 0 0         if ($char[$i] eq '\E') {
5607 0           last;
5608             }
5609             }
5610             }
5611             elsif ($char[$i] eq '\E') {
5612             }
5613              
5614             # $0 --> $0
5615             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5616 0 0         if ($ignorecase) {
5617 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
5618             }
5619             }
5620             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5621 0 0         if ($ignorecase) {
5622 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
5623             }
5624             }
5625              
5626             # $$ --> $$
5627             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5628             }
5629              
5630             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5631             # $1, $2, $3 --> $1, $2, $3 otherwise
5632             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5633 0           $char[$i] = e_capture($1);
5634 0 0         if ($ignorecase) {
5635 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
5636             }
5637             }
5638             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5639 0           $char[$i] = e_capture($1);
5640 0 0         if ($ignorecase) {
5641 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
5642             }
5643             }
5644              
5645             # $$foo[ ... ] --> $ $foo->[ ... ]
5646             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5647 0           $char[$i] = e_capture($1.'->'.$2);
5648 0 0         if ($ignorecase) {
5649 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
5650             }
5651             }
5652              
5653             # $$foo{ ... } --> $ $foo->{ ... }
5654             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5655 0           $char[$i] = e_capture($1.'->'.$2);
5656 0 0         if ($ignorecase) {
5657 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
5658             }
5659             }
5660              
5661             # $$foo
5662             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5663 0           $char[$i] = e_capture($1);
5664 0 0         if ($ignorecase) {
5665 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
5666             }
5667             }
5668              
5669             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
5670             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5671 0 0         if ($ignorecase) {
5672 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::PREMATCH())]}';
5673             }
5674             else {
5675 0           $char[$i] = '@{[Char::Eusascii::PREMATCH()]}';
5676             }
5677             }
5678              
5679             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
5680             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5681 0 0         if ($ignorecase) {
5682 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::MATCH())]}';
5683             }
5684             else {
5685 0           $char[$i] = '@{[Char::Eusascii::MATCH()]}';
5686             }
5687             }
5688              
5689             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
5690             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5691 0 0         if ($ignorecase) {
5692 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::POSTMATCH())]}';
5693             }
5694             else {
5695 0           $char[$i] = '@{[Char::Eusascii::POSTMATCH()]}';
5696             }
5697             }
5698              
5699             # ${ foo }
5700             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5701 0 0         if ($ignorecase) {
5702 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
5703             }
5704             }
5705              
5706             # ${ ... }
5707             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5708 0           $char[$i] = e_capture($1);
5709 0 0         if ($ignorecase) {
5710 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
5711             }
5712             }
5713              
5714             # $scalar or @array
5715             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5716 0           $char[$i] = e_string($char[$i]);
5717 0 0         if ($ignorecase) {
5718 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
5719             }
5720             }
5721              
5722             # quote character before ? + * {
5723             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5724 0 0 0       if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5725             }
5726             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5727 0           my $char = $char[$i-1];
5728 0 0         if ($char[$i] eq '{') {
5729 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}};
5730             }
5731             else {
5732 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]};
5733             }
5734             }
5735             else {
5736 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5737             }
5738             }
5739             }
5740              
5741             # make regexp string
5742 0           $modifier =~ tr/i//d;
5743 0 0         if ($left_e > $right_e) {
5744 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5745 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5746             }
5747             else {
5748 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5749             }
5750             }
5751 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5752 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5753             }
5754             else {
5755 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5756             }
5757             }
5758              
5759             #
5760             # double quote stuff
5761             #
5762             sub qq_stuff {
5763 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5764              
5765             # scalar variable or array variable
5766 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5767 0           return $stuff;
5768             }
5769              
5770             # quote by delimiter
5771 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5772 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5773 0 0         next if $char eq $delimiter;
5774 0 0         next if $char eq $end_delimiter;
5775 0 0         if (not $octet{$char}) {
5776 0           return join '', 'qq', $char, $stuff, $char;
5777             }
5778             }
5779 0           return join '', 'qq', '<', $stuff, '>';
5780             }
5781              
5782             #
5783             # escape regexp (m'', qr'', and m''b, qr''b)
5784             #
5785             sub e_qr_q {
5786 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5787 0   0       $modifier ||= '';
5788              
5789 0           $modifier =~ tr/p//d;
5790 0 0         if ($modifier =~ /([adlu])/oxms) {
5791 0           my $line = 0;
5792 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5793 0 0         if ($filename ne __FILE__) {
5794 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5795 0           last;
5796             }
5797             }
5798 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5799             }
5800              
5801 0           $slash = 'div';
5802              
5803             # literal null string pattern
5804 0 0         if ($string eq '') {
    0          
5805 0           $modifier =~ tr/bB//d;
5806 0           $modifier =~ tr/i//d;
5807 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5808             }
5809              
5810             # with /b /B modifier
5811             elsif ($modifier =~ tr/bB//d) {
5812 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5813             }
5814              
5815             # without /b /B modifier
5816             else {
5817 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5818             }
5819             }
5820              
5821             #
5822             # escape regexp (m'', qr'')
5823             #
5824             sub e_qr_qt {
5825 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5826              
5827 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5828              
5829             # split regexp
5830 0           my @char = $string =~ /\G(
5831             \[\:\^ [a-z]+ \:\] |
5832             \[\: [a-z]+ \:\] |
5833             \[\^ |
5834             [\$\@\/\\] |
5835             \\? (?:$q_char)
5836             )/oxmsg;
5837              
5838             # unescape character
5839 0           for (my $i=0; $i <= $#char; $i++) {
5840 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
5841             }
5842              
5843             # open character class [...]
5844 0           elsif ($char[$i] eq '[') {
5845 0           my $left = $i;
5846 0 0         if ($char[$i+1] eq ']') {
5847 0           $i++;
5848             }
5849 0           while (1) {
5850 0 0         if (++$i > $#char) {
5851 0           die __FILE__, ": Unmatched [] in regexp";
5852             }
5853 0 0         if ($char[$i] eq ']') {
5854 0           my $right = $i;
5855              
5856             # [...]
5857 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
5858              
5859 0           $i = $left;
5860 0           last;
5861             }
5862             }
5863             }
5864              
5865             # open character class [^...]
5866             elsif ($char[$i] eq '[^') {
5867 0           my $left = $i;
5868 0 0         if ($char[$i+1] eq ']') {
5869 0           $i++;
5870             }
5871 0           while (1) {
5872 0 0         if (++$i > $#char) {
5873 0           die __FILE__, ": Unmatched [] in regexp";
5874             }
5875 0 0         if ($char[$i] eq ']') {
5876 0           my $right = $i;
5877              
5878             # [^...]
5879 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5880              
5881 0           $i = $left;
5882 0           last;
5883             }
5884             }
5885             }
5886              
5887             # escape $ @ / and \
5888             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5889 0           $char[$i] = '\\' . $char[$i];
5890             }
5891              
5892             # rewrite character class or escape character
5893             elsif (my $char = character_class($char[$i],$modifier)) {
5894 0           $char[$i] = $char;
5895             }
5896              
5897             # /i modifier
5898             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
5899 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
5900 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
5901             }
5902             else {
5903 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
5904             }
5905             }
5906              
5907             # quote character before ? + * {
5908             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5909 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
5910             }
5911             else {
5912 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5913             }
5914             }
5915             }
5916              
5917 0           $delimiter = '/';
5918 0           $end_delimiter = '/';
5919              
5920 0           $modifier =~ tr/i//d;
5921 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5922             }
5923              
5924             #
5925             # escape regexp (m''b, qr''b)
5926             #
5927             sub e_qr_qb {
5928 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5929              
5930             # split regexp
5931 0           my @char = $string =~ /\G(
5932             \\\\ |
5933             [\$\@\/\\] |
5934             [\x00-\xFF]
5935             )/oxmsg;
5936              
5937             # unescape character
5938 0           for (my $i=0; $i <= $#char; $i++) {
5939 0 0         if (0) {
    0          
5940             }
5941              
5942             # remain \\
5943 0           elsif ($char[$i] eq '\\\\') {
5944             }
5945              
5946             # escape $ @ / and \
5947             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5948 0           $char[$i] = '\\' . $char[$i];
5949             }
5950             }
5951              
5952 0           $delimiter = '/';
5953 0           $end_delimiter = '/';
5954 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5955             }
5956              
5957             #
5958             # escape regexp (s/here//)
5959             #
5960             sub e_s1 {
5961 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5962 0   0       $modifier ||= '';
5963              
5964 0           $modifier =~ tr/p//d;
5965 0 0         if ($modifier =~ /([adlu])/oxms) {
5966 0           my $line = 0;
5967 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5968 0 0         if ($filename ne __FILE__) {
5969 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5970 0           last;
5971             }
5972             }
5973 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5974             }
5975              
5976 0           $slash = 'div';
5977              
5978             # literal null string pattern
5979 0 0         if ($string eq '') {
    0          
5980 0           $modifier =~ tr/bB//d;
5981 0           $modifier =~ tr/i//d;
5982 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5983             }
5984              
5985             # /b /B modifier
5986             elsif ($modifier =~ tr/bB//d) {
5987              
5988             # choice again delimiter
5989 0 0         if ($delimiter =~ / [\@:] /oxms) {
5990 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
5991 0           my %octet = map {$_ => 1} @char;
  0            
5992 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5993 0           $delimiter = '(';
5994 0           $end_delimiter = ')';
5995             }
5996             elsif (not $octet{'}'}) {
5997 0           $delimiter = '{';
5998 0           $end_delimiter = '}';
5999             }
6000             elsif (not $octet{']'}) {
6001 0           $delimiter = '[';
6002 0           $end_delimiter = ']';
6003             }
6004             elsif (not $octet{'>'}) {
6005 0           $delimiter = '<';
6006 0           $end_delimiter = '>';
6007             }
6008             else {
6009 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6010 0 0         if (not $octet{$char}) {
6011 0           $delimiter = $char;
6012 0           $end_delimiter = $char;
6013 0           last;
6014             }
6015             }
6016             }
6017             }
6018              
6019 0           my $prematch = '';
6020 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6021             }
6022              
6023 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6024 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6025              
6026             # split regexp
6027 0           my @char = $string =~ /\G(
6028             \\g \s* \{ \s* - \s* [1-9][0-9]* \s* \} |
6029             \\g \s* \{ \s* [1-9][0-9]* \s* \} |
6030             \\g \s* [1-9][0-9]* |
6031             \\o\{ [0-7]+ \} |
6032             \\ [1-9][0-9]* |
6033             \\ [0-7]{2,3} |
6034             \\x\{ [0-9A-Fa-f]+ \} |
6035             \\x [0-9A-Fa-f]{1,2} |
6036             \\c [\x40-\x5F] |
6037             \\N\{ [^0-9\}][^\}]* \} |
6038             \\p\{ [^0-9\}][^\}]* \} |
6039             \\P\{ [^0-9\}][^\}]* \} |
6040             \\ (?:$q_char) |
6041             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6042             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6043             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6044             [\$\@] $qq_variable |
6045             \$ \s* \d+ |
6046             \$ \s* \{ \s* \d+ \s* \} |
6047             \$ \$ (?![\w\{]) |
6048             \$ \s* \$ \s* $qq_variable |
6049             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6050             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6051             \[\^ |
6052             \(\? |
6053             (?:$q_char)
6054             )/oxmsg;
6055              
6056             # choice again delimiter
6057 0 0         if ($delimiter =~ / [\@:] /oxms) {
6058 0           my %octet = map {$_ => 1} @char;
  0            
6059 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6060 0           $delimiter = '(';
6061 0           $end_delimiter = ')';
6062             }
6063             elsif (not $octet{'}'}) {
6064 0           $delimiter = '{';
6065 0           $end_delimiter = '}';
6066             }
6067             elsif (not $octet{']'}) {
6068 0           $delimiter = '[';
6069 0           $end_delimiter = ']';
6070             }
6071             elsif (not $octet{'>'}) {
6072 0           $delimiter = '<';
6073 0           $end_delimiter = '>';
6074             }
6075             else {
6076 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6077 0 0         if (not $octet{$char}) {
6078 0           $delimiter = $char;
6079 0           $end_delimiter = $char;
6080 0           last;
6081             }
6082             }
6083             }
6084             }
6085              
6086             # count '('
6087 0           my $parens = grep { $_ eq '(' } @char;
  0            
6088              
6089 0           my $left_e = 0;
6090 0           my $right_e = 0;
6091 0           for (my $i=0; $i <= $#char; $i++) {
6092              
6093             # "\L\u" --> "\u\L"
6094 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
6095 0           @char[$i,$i+1] = @char[$i+1,$i];
6096             }
6097              
6098             # "\U\l" --> "\l\U"
6099             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6100 0           @char[$i,$i+1] = @char[$i+1,$i];
6101             }
6102              
6103             # octal escape sequence
6104             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6105 0           $char[$i] = Char::Eusascii::octchr($1);
6106             }
6107              
6108             # hexadecimal escape sequence
6109             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6110 0           $char[$i] = Char::Eusascii::hexchr($1);
6111             }
6112              
6113             # \N{CHARNAME} --> N\{CHARNAME}
6114             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6115 0           $char[$i] = $1 . '\\' . $2;
6116             }
6117              
6118             # \p{PROPERTY} --> p\{PROPERTY}
6119             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6120 0           $char[$i] = $1 . '\\' . $2;
6121             }
6122              
6123             # \P{PROPERTY} --> P\{PROPERTY}
6124             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6125 0           $char[$i] = $1 . '\\' . $2;
6126             }
6127              
6128             # \p, \P, \X --> p, P, X
6129             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6130 0           $char[$i] = $1;
6131             }
6132              
6133 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          
6134             }
6135              
6136             # join separated multiple-octet
6137 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6138 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 (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
6139 0           $char[$i] .= join '', splice @char, $i+1, 3;
6140             }
6141             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
6142 0           $char[$i] .= join '', splice @char, $i+1, 2;
6143             }
6144             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
6145 0           $char[$i] .= join '', splice @char, $i+1, 1;
6146             }
6147             }
6148              
6149             # open character class [...]
6150             elsif ($char[$i] eq '[') {
6151 0           my $left = $i;
6152 0 0         if ($char[$i+1] eq ']') {
6153 0           $i++;
6154             }
6155 0           while (1) {
6156 0 0         if (++$i > $#char) {
6157 0           die __FILE__, ": Unmatched [] in regexp";
6158             }
6159 0 0         if ($char[$i] eq ']') {
6160 0           my $right = $i;
6161              
6162             # [...]
6163 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6164 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6165             }
6166             else {
6167 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
6168             }
6169              
6170 0           $i = $left;
6171 0           last;
6172             }
6173             }
6174             }
6175              
6176             # open character class [^...]
6177             elsif ($char[$i] eq '[^') {
6178 0           my $left = $i;
6179 0 0         if ($char[$i+1] eq ']') {
6180 0           $i++;
6181             }
6182 0           while (1) {
6183 0 0         if (++$i > $#char) {
6184 0           die __FILE__, ": Unmatched [] in regexp";
6185             }
6186 0 0         if ($char[$i] eq ']') {
6187 0           my $right = $i;
6188              
6189             # [^...]
6190 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6191 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6192             }
6193             else {
6194 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6195             }
6196              
6197 0           $i = $left;
6198 0           last;
6199             }
6200             }
6201             }
6202              
6203             # rewrite character class or escape character
6204             elsif (my $char = character_class($char[$i],$modifier)) {
6205 0           $char[$i] = $char;
6206             }
6207              
6208             # /i modifier
6209             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
6210 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
6211 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
6212             }
6213             else {
6214 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
6215             }
6216             }
6217              
6218             # \u \l \U \L \F \Q \E
6219             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6220 0 0         if ($right_e < $left_e) {
6221 0           $char[$i] = '\\' . $char[$i];
6222             }
6223             }
6224             elsif ($char[$i] eq '\u') {
6225 0           $char[$i] = '@{[Char::Eusascii::ucfirst qq<';
6226 0           $left_e++;
6227             }
6228             elsif ($char[$i] eq '\l') {
6229 0           $char[$i] = '@{[Char::Eusascii::lcfirst qq<';
6230 0           $left_e++;
6231             }
6232             elsif ($char[$i] eq '\U') {
6233 0           $char[$i] = '@{[Char::Eusascii::uc qq<';
6234 0           $left_e++;
6235             }
6236             elsif ($char[$i] eq '\L') {
6237 0           $char[$i] = '@{[Char::Eusascii::lc qq<';
6238 0           $left_e++;
6239             }
6240             elsif ($char[$i] eq '\F') {
6241 0           $char[$i] = '@{[Char::Eusascii::fc qq<';
6242 0           $left_e++;
6243             }
6244             elsif ($char[$i] eq '\Q') {
6245 0           $char[$i] = '@{[CORE::quotemeta qq<';
6246 0           $left_e++;
6247             }
6248             elsif ($char[$i] eq '\E') {
6249 0 0         if ($right_e < $left_e) {
6250 0           $char[$i] = '>]}';
6251 0           $right_e++;
6252             }
6253             else {
6254 0           $char[$i] = '';
6255             }
6256             }
6257             elsif ($char[$i] eq '\Q') {
6258 0           while (1) {
6259 0 0         if (++$i > $#char) {
6260 0           last;
6261             }
6262 0 0         if ($char[$i] eq '\E') {
6263 0           last;
6264             }
6265             }
6266             }
6267             elsif ($char[$i] eq '\E') {
6268             }
6269              
6270             # \0 --> \0
6271             elsif ($char[$i] =~ /\A \\ \s* 0 \z/oxms) {
6272             }
6273              
6274             # \g{N}, \g{-N}
6275              
6276             # P.108 Using Simple Patterns
6277             # in Chapter 7: In the World of Regular Expressions
6278             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6279              
6280             # P.221 Capturing
6281             # in Chapter 5: Pattern Matching
6282             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6283              
6284             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6285             elsif ($char[$i] =~ /\A \\g \s* \{ \s* - \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6286             }
6287              
6288             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6289             elsif ($char[$i] =~ /\A \\g \s* \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6290             }
6291              
6292             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6293             elsif ($char[$i] =~ /\A \\g \s* ([1-9][0-9]*) \z/oxms) {
6294             }
6295              
6296             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6297             elsif ($char[$i] =~ /\A \\ \s* ([1-9][0-9]*) \z/oxms) {
6298             }
6299              
6300             # $0 --> $0
6301             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6302 0 0         if ($ignorecase) {
6303 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
6304             }
6305             }
6306             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
6307 0 0         if ($ignorecase) {
6308 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
6309             }
6310             }
6311              
6312             # $$ --> $$
6313             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6314             }
6315              
6316             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6317             # $1, $2, $3 --> $1, $2, $3 otherwise
6318             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
6319 0           $char[$i] = e_capture($1);
6320 0 0         if ($ignorecase) {
6321 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
6322             }
6323             }
6324             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6325 0           $char[$i] = e_capture($1);
6326 0 0         if ($ignorecase) {
6327 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
6328             }
6329             }
6330              
6331             # $$foo[ ... ] --> $ $foo->[ ... ]
6332             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6333 0           $char[$i] = e_capture($1.'->'.$2);
6334 0 0         if ($ignorecase) {
6335 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
6336             }
6337             }
6338              
6339             # $$foo{ ... } --> $ $foo->{ ... }
6340             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6341 0           $char[$i] = e_capture($1.'->'.$2);
6342 0 0         if ($ignorecase) {
6343 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
6344             }
6345             }
6346              
6347             # $$foo
6348             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
6349 0           $char[$i] = e_capture($1);
6350 0 0         if ($ignorecase) {
6351 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
6352             }
6353             }
6354              
6355             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
6356             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
6357 0 0         if ($ignorecase) {
6358 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::PREMATCH())]}';
6359             }
6360             else {
6361 0           $char[$i] = '@{[Char::Eusascii::PREMATCH()]}';
6362             }
6363             }
6364              
6365             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
6366             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
6367 0 0         if ($ignorecase) {
6368 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::MATCH())]}';
6369             }
6370             else {
6371 0           $char[$i] = '@{[Char::Eusascii::MATCH()]}';
6372             }
6373             }
6374              
6375             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
6376             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
6377 0 0         if ($ignorecase) {
6378 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::POSTMATCH())]}';
6379             }
6380             else {
6381 0           $char[$i] = '@{[Char::Eusascii::POSTMATCH()]}';
6382             }
6383             }
6384              
6385             # ${ foo }
6386             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
6387 0 0         if ($ignorecase) {
6388 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
6389             }
6390             }
6391              
6392             # ${ ... }
6393             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
6394 0           $char[$i] = e_capture($1);
6395 0 0         if ($ignorecase) {
6396 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
6397             }
6398             }
6399              
6400             # $scalar or @array
6401             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6402 0           $char[$i] = e_string($char[$i]);
6403 0 0         if ($ignorecase) {
6404 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
6405             }
6406             }
6407              
6408             # quote character before ? + * {
6409             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6410 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6411             }
6412             else {
6413 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6414             }
6415             }
6416             }
6417              
6418             # make regexp string
6419 0           my $prematch = '';
6420 0           $modifier =~ tr/i//d;
6421 0 0         if ($left_e > $right_e) {
6422 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6423             }
6424 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6425             }
6426              
6427             #
6428             # escape regexp (s'here'' or s'here''b)
6429             #
6430             sub e_s1_q {
6431 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6432 0   0       $modifier ||= '';
6433              
6434 0           $modifier =~ tr/p//d;
6435 0 0         if ($modifier =~ /([adlu])/oxms) {
6436 0           my $line = 0;
6437 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6438 0 0         if ($filename ne __FILE__) {
6439 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6440 0           last;
6441             }
6442             }
6443 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6444             }
6445              
6446 0           $slash = 'div';
6447              
6448             # literal null string pattern
6449 0 0         if ($string eq '') {
    0          
6450 0           $modifier =~ tr/bB//d;
6451 0           $modifier =~ tr/i//d;
6452 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6453             }
6454              
6455             # with /b /B modifier
6456             elsif ($modifier =~ tr/bB//d) {
6457 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6458             }
6459              
6460             # without /b /B modifier
6461             else {
6462 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6463             }
6464             }
6465              
6466             #
6467             # escape regexp (s'here'')
6468             #
6469             sub e_s1_qt {
6470 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6471              
6472 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6473              
6474             # split regexp
6475 0           my @char = $string =~ /\G(
6476             \[\:\^ [a-z]+ \:\] |
6477             \[\: [a-z]+ \:\] |
6478             \[\^ |
6479             [\$\@\/\\] |
6480             \\? (?:$q_char)
6481             )/oxmsg;
6482              
6483             # unescape character
6484 0           for (my $i=0; $i <= $#char; $i++) {
6485 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6486             }
6487              
6488             # open character class [...]
6489 0           elsif ($char[$i] eq '[') {
6490 0           my $left = $i;
6491 0 0         if ($char[$i+1] eq ']') {
6492 0           $i++;
6493             }
6494 0           while (1) {
6495 0 0         if (++$i > $#char) {
6496 0           die __FILE__, ": Unmatched [] in regexp";
6497             }
6498 0 0         if ($char[$i] eq ']') {
6499 0           my $right = $i;
6500              
6501             # [...]
6502 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
6503              
6504 0           $i = $left;
6505 0           last;
6506             }
6507             }
6508             }
6509              
6510             # open character class [^...]
6511             elsif ($char[$i] eq '[^') {
6512 0           my $left = $i;
6513 0 0         if ($char[$i+1] eq ']') {
6514 0           $i++;
6515             }
6516 0           while (1) {
6517 0 0         if (++$i > $#char) {
6518 0           die __FILE__, ": Unmatched [] in regexp";
6519             }
6520 0 0         if ($char[$i] eq ']') {
6521 0           my $right = $i;
6522              
6523             # [^...]
6524 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6525              
6526 0           $i = $left;
6527 0           last;
6528             }
6529             }
6530             }
6531              
6532             # escape $ @ / and \
6533             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6534 0           $char[$i] = '\\' . $char[$i];
6535             }
6536              
6537             # rewrite character class or escape character
6538             elsif (my $char = character_class($char[$i],$modifier)) {
6539 0           $char[$i] = $char;
6540             }
6541              
6542             # /i modifier
6543             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
6544 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
6545 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
6546             }
6547             else {
6548 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
6549             }
6550             }
6551              
6552             # quote character before ? + * {
6553             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6554 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6555             }
6556             else {
6557 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6558             }
6559             }
6560             }
6561              
6562 0           $modifier =~ tr/i//d;
6563 0           $delimiter = '/';
6564 0           $end_delimiter = '/';
6565 0           my $prematch = '';
6566 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6567             }
6568              
6569             #
6570             # escape regexp (s'here''b)
6571             #
6572             sub e_s1_qb {
6573 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6574              
6575             # split regexp
6576 0           my @char = $string =~ /\G(
6577             \\\\ |
6578             [\$\@\/\\] |
6579             [\x00-\xFF]
6580             )/oxmsg;
6581              
6582             # unescape character
6583 0           for (my $i=0; $i <= $#char; $i++) {
6584 0 0         if (0) {
    0          
6585             }
6586              
6587             # remain \\
6588 0           elsif ($char[$i] eq '\\\\') {
6589             }
6590              
6591             # escape $ @ / and \
6592             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6593 0           $char[$i] = '\\' . $char[$i];
6594             }
6595             }
6596              
6597 0           $delimiter = '/';
6598 0           $end_delimiter = '/';
6599 0           my $prematch = '';
6600 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6601             }
6602              
6603             #
6604             # escape regexp (s''here')
6605             #
6606             sub e_s2_q {
6607 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6608              
6609 0           $slash = 'div';
6610              
6611 0           my @char = $string =~ / \G (\\\\|[\$\@\/\\]|$q_char) /oxmsg;
6612 0           for (my $i=0; $i <= $#char; $i++) {
6613 0 0         if (0) {
    0          
6614             }
6615              
6616             # not escape \\
6617 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6618             }
6619              
6620             # escape $ @ / and \
6621             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6622 0           $char[$i] = '\\' . $char[$i];
6623             }
6624             }
6625              
6626 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6627             }
6628              
6629             #
6630             # escape regexp (s/here/and here/modifier)
6631             #
6632             sub e_sub {
6633 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6634 0   0       $modifier ||= '';
6635              
6636 0           $modifier =~ tr/p//d;
6637 0 0         if ($modifier =~ /([adlu])/oxms) {
6638 0           my $line = 0;
6639 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6640 0 0         if ($filename ne __FILE__) {
6641 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6642 0           last;
6643             }
6644             }
6645 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6646             }
6647              
6648 0 0         if ($variable eq '') {
6649 0           $variable = '$_';
6650 0           $bind_operator = ' =~ ';
6651             }
6652              
6653 0           $slash = 'div';
6654              
6655             # P.128 Start of match (or end of previous match): \G
6656             # P.130 Advanced Use of \G with Perl
6657             # in Chapter 3: Overview of Regular Expression Features and Flavors
6658             # P.312 Iterative Matching: Scalar Context, with /g
6659             # in Chapter 7: Perl
6660             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6661              
6662             # P.181 Where You Left Off: The \G Assertion
6663             # in Chapter 5: Pattern Matching
6664             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6665              
6666             # P.220 Where You Left Off: The \G Assertion
6667             # in Chapter 5: Pattern Matching
6668             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6669              
6670 0           my $e_modifier = $modifier =~ tr/e//d;
6671 0           my $r_modifier = $modifier =~ tr/r//d;
6672              
6673 0           my $my = '';
6674 0 0         if ($variable =~ s/\A \( \s* ( (?: local \b | my \b | our \b | state \b )? .+ ) \) \z/$1/oxms) {
6675 0           $my = $variable;
6676 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) \s* //oxms;
6677 0           $variable =~ s/ = .+ \z//oxms;
6678             }
6679              
6680 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6681 0           $variable_basename =~ s/ \s+ \z//oxms;
6682              
6683             # quote replacement string
6684 0           my $e_replacement = '';
6685 0 0         if ($e_modifier >= 1) {
6686 0           $e_replacement = e_qq('', '', '', $replacement);
6687 0           $e_modifier--;
6688             }
6689             else {
6690 0 0         if ($delimiter2 eq "'") {
6691 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6692             }
6693             else {
6694 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6695             }
6696             }
6697              
6698 0           my $sub = '';
6699              
6700             # with /r
6701 0 0         if ($r_modifier) {
6702 0 0         if (0) {
6703             }
6704              
6705             # s///gr without multibyte anchoring
6706 0           elsif ($modifier =~ /g/oxms) {
6707 0 0         $sub = sprintf(
6708             # 1 2 3 4 5
6709             q,
6710              
6711             $variable, # 1
6712             ($delimiter1 eq "'") ? # 2
6713             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6714             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6715             $s_matched, # 3
6716             $e_replacement, # 4
6717             '$Char::USASCII::re_r=CORE::eval $Char::USASCII::re_r; ' x $e_modifier, # 5
6718             );
6719             }
6720              
6721             # s///r
6722             else {
6723              
6724 0           my $prematch = q{$`};
6725              
6726 0 0         $sub = sprintf(
6727             # 1 2 3 4 5 6 7
6728             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Char::USASCII::re_r=%s; %s"%s$Char::USASCII::re_r$'" } : %s>,
6729              
6730             $variable, # 1
6731             ($delimiter1 eq "'") ? # 2
6732             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6733             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6734             $s_matched, # 3
6735             $e_replacement, # 4
6736             '$Char::USASCII::re_r=CORE::eval $Char::USASCII::re_r; ' x $e_modifier, # 5
6737             $prematch, # 6
6738             $variable, # 7
6739             );
6740             }
6741              
6742             # $var !~ s///r doesn't make sense
6743 0 0         if ($bind_operator =~ / !~ /oxms) {
6744 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6745             }
6746             }
6747              
6748             # without /r
6749             else {
6750 0 0         if (0) {
6751             }
6752              
6753             # s///g without multibyte anchoring
6754 0           elsif ($modifier =~ /g/oxms) {
6755 0 0         $sub = sprintf(
    0          
6756             # 1 2 3 4 5 6 7 8
6757             q,
6758              
6759             $variable, # 1
6760             ($delimiter1 eq "'") ? # 2
6761             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6762             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6763             $s_matched, # 3
6764             $e_replacement, # 4
6765             '$Char::USASCII::re_r=CORE::eval $Char::USASCII::re_r; ' x $e_modifier, # 5
6766             $variable, # 6
6767             $variable, # 7
6768             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6769             );
6770             }
6771              
6772             # s///
6773             else {
6774              
6775 0           my $prematch = q{$`};
6776              
6777 0 0         $sub = sprintf(
    0          
6778              
6779             ($bind_operator =~ / =~ /oxms) ?
6780              
6781             # 1 2 3 4 5 6 7 8
6782             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Char::USASCII::re_r=%s; %s%s="%s$Char::USASCII::re_r$'"; 1 } : undef> :
6783              
6784             # 1 2 3 4 5 6 7 8
6785             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Char::USASCII::re_r=%s; %s%s="%s$Char::USASCII::re_r$'"; undef }>,
6786              
6787             $variable, # 1
6788             $bind_operator, # 2
6789             ($delimiter1 eq "'") ? # 3
6790             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6791             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6792             $s_matched, # 4
6793             $e_replacement, # 5
6794             '$Char::USASCII::re_r=CORE::eval $Char::USASCII::re_r; ' x $e_modifier, # 6
6795             $variable, # 7
6796             $prematch, # 8
6797             );
6798             }
6799             }
6800              
6801             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6802 0 0         if ($my ne '') {
6803 0           $sub = "($my, $sub)[1]";
6804             }
6805              
6806             # clear s/// variable
6807 0           $sub_variable = '';
6808 0           $bind_operator = '';
6809              
6810 0           return $sub;
6811             }
6812              
6813             #
6814             # escape regexp of split qr//
6815             #
6816             sub e_split {
6817 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6818 0   0       $modifier ||= '';
6819              
6820 0           $modifier =~ tr/p//d;
6821 0 0         if ($modifier =~ /([adlu])/oxms) {
6822 0           my $line = 0;
6823 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6824 0 0         if ($filename ne __FILE__) {
6825 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6826 0           last;
6827             }
6828             }
6829 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6830             }
6831              
6832 0           $slash = 'div';
6833              
6834             # /b /B modifier
6835 0 0         if ($modifier =~ tr/bB//d) {
6836 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6837             }
6838              
6839 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6840 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6841              
6842             # split regexp
6843 0           my @char = $string =~ /\G(
6844             \\o\{ [0-7]+ \} |
6845             \\ [0-7]{2,3} |
6846             \\x\{ [0-9A-Fa-f]+ \} |
6847             \\x [0-9A-Fa-f]{1,2} |
6848             \\c [\x40-\x5F] |
6849             \\N\{ [^0-9\}][^\}]* \} |
6850             \\p\{ [^0-9\}][^\}]* \} |
6851             \\P\{ [^0-9\}][^\}]* \} |
6852             \\ (?:$q_char) |
6853             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6854             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6855             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6856             [\$\@] $qq_variable |
6857             \$ \s* \d+ |
6858             \$ \s* \{ \s* \d+ \s* \} |
6859             \$ \$ (?![\w\{]) |
6860             \$ \s* \$ \s* $qq_variable |
6861             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6862             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6863             \[\^ |
6864             \(\? |
6865             (?:$q_char)
6866             )/oxmsg;
6867              
6868 0           my $left_e = 0;
6869 0           my $right_e = 0;
6870 0           for (my $i=0; $i <= $#char; $i++) {
6871              
6872             # "\L\u" --> "\u\L"
6873 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
6874 0           @char[$i,$i+1] = @char[$i+1,$i];
6875             }
6876              
6877             # "\U\l" --> "\l\U"
6878             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6879 0           @char[$i,$i+1] = @char[$i+1,$i];
6880             }
6881              
6882             # octal escape sequence
6883             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6884 0           $char[$i] = Char::Eusascii::octchr($1);
6885             }
6886              
6887             # hexadecimal escape sequence
6888             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6889 0           $char[$i] = Char::Eusascii::hexchr($1);
6890             }
6891              
6892             # \N{CHARNAME} --> N\{CHARNAME}
6893             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6894 0           $char[$i] = $1 . '\\' . $2;
6895             }
6896              
6897             # \p{PROPERTY} --> p\{PROPERTY}
6898             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6899 0           $char[$i] = $1 . '\\' . $2;
6900             }
6901              
6902             # \P{PROPERTY} --> P\{PROPERTY}
6903             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6904 0           $char[$i] = $1 . '\\' . $2;
6905             }
6906              
6907             # \p, \P, \X --> p, P, X
6908             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6909 0           $char[$i] = $1;
6910             }
6911              
6912 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          
6913             }
6914              
6915             # join separated multiple-octet
6916 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6917 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 (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
6918 0           $char[$i] .= join '', splice @char, $i+1, 3;
6919             }
6920             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
6921 0           $char[$i] .= join '', splice @char, $i+1, 2;
6922             }
6923             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
6924 0           $char[$i] .= join '', splice @char, $i+1, 1;
6925             }
6926             }
6927              
6928             # open character class [...]
6929             elsif ($char[$i] eq '[') {
6930 0           my $left = $i;
6931 0 0         if ($char[$i+1] eq ']') {
6932 0           $i++;
6933             }
6934 0           while (1) {
6935 0 0         if (++$i > $#char) {
6936 0           die __FILE__, ": Unmatched [] in regexp";
6937             }
6938 0 0         if ($char[$i] eq ']') {
6939 0           my $right = $i;
6940              
6941             # [...]
6942 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6943 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6944             }
6945             else {
6946 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
6947             }
6948              
6949 0           $i = $left;
6950 0           last;
6951             }
6952             }
6953             }
6954              
6955             # open character class [^...]
6956             elsif ($char[$i] eq '[^') {
6957 0           my $left = $i;
6958 0 0         if ($char[$i+1] eq ']') {
6959 0           $i++;
6960             }
6961 0           while (1) {
6962 0 0         if (++$i > $#char) {
6963 0           die __FILE__, ": Unmatched [] in regexp";
6964             }
6965 0 0         if ($char[$i] eq ']') {
6966 0           my $right = $i;
6967              
6968             # [^...]
6969 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6970 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Eusascii::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6971             }
6972             else {
6973 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6974             }
6975              
6976 0           $i = $left;
6977 0           last;
6978             }
6979             }
6980             }
6981              
6982             # rewrite character class or escape character
6983             elsif (my $char = character_class($char[$i],$modifier)) {
6984 0           $char[$i] = $char;
6985             }
6986              
6987             # P.794 29.2.161. split
6988             # in Chapter 29: Functions
6989             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6990              
6991             # P.951 split
6992             # in Chapter 27: Functions
6993             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6994              
6995             # said "The //m modifier is assumed when you split on the pattern /^/",
6996             # but perl5.008 is not so. Therefore, this software adds //m.
6997             # (and so on)
6998              
6999             # split(m/^/) --> split(m/^/m)
7000             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7001 0           $modifier .= 'm';
7002             }
7003              
7004             # /i modifier
7005             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
7006 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
7007 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
7008             }
7009             else {
7010 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
7011             }
7012             }
7013              
7014             # \u \l \U \L \F \Q \E
7015             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7016 0 0         if ($right_e < $left_e) {
7017 0           $char[$i] = '\\' . $char[$i];
7018             }
7019             }
7020             elsif ($char[$i] eq '\u') {
7021 0           $char[$i] = '@{[Char::Eusascii::ucfirst qq<';
7022 0           $left_e++;
7023             }
7024             elsif ($char[$i] eq '\l') {
7025 0           $char[$i] = '@{[Char::Eusascii::lcfirst qq<';
7026 0           $left_e++;
7027             }
7028             elsif ($char[$i] eq '\U') {
7029 0           $char[$i] = '@{[Char::Eusascii::uc qq<';
7030 0           $left_e++;
7031             }
7032             elsif ($char[$i] eq '\L') {
7033 0           $char[$i] = '@{[Char::Eusascii::lc qq<';
7034 0           $left_e++;
7035             }
7036             elsif ($char[$i] eq '\F') {
7037 0           $char[$i] = '@{[Char::Eusascii::fc qq<';
7038 0           $left_e++;
7039             }
7040             elsif ($char[$i] eq '\Q') {
7041 0           $char[$i] = '@{[CORE::quotemeta qq<';
7042 0           $left_e++;
7043             }
7044             elsif ($char[$i] eq '\E') {
7045 0 0         if ($right_e < $left_e) {
7046 0           $char[$i] = '>]}';
7047 0           $right_e++;
7048             }
7049             else {
7050 0           $char[$i] = '';
7051             }
7052             }
7053             elsif ($char[$i] eq '\Q') {
7054 0           while (1) {
7055 0 0         if (++$i > $#char) {
7056 0           last;
7057             }
7058 0 0         if ($char[$i] eq '\E') {
7059 0           last;
7060             }
7061             }
7062             }
7063             elsif ($char[$i] eq '\E') {
7064             }
7065              
7066             # $0 --> $0
7067             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7068 0 0         if ($ignorecase) {
7069 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
7070             }
7071             }
7072             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
7073 0 0         if ($ignorecase) {
7074 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
7075             }
7076             }
7077              
7078             # $$ --> $$
7079             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7080             }
7081              
7082             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7083             # $1, $2, $3 --> $1, $2, $3 otherwise
7084             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
7085 0           $char[$i] = e_capture($1);
7086 0 0         if ($ignorecase) {
7087 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
7088             }
7089             }
7090             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
7091 0           $char[$i] = e_capture($1);
7092 0 0         if ($ignorecase) {
7093 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
7094             }
7095             }
7096              
7097             # $$foo[ ... ] --> $ $foo->[ ... ]
7098             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7099 0           $char[$i] = e_capture($1.'->'.$2);
7100 0 0         if ($ignorecase) {
7101 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
7102             }
7103             }
7104              
7105             # $$foo{ ... } --> $ $foo->{ ... }
7106             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7107 0           $char[$i] = e_capture($1.'->'.$2);
7108 0 0         if ($ignorecase) {
7109 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
7110             }
7111             }
7112              
7113             # $$foo
7114             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
7115 0           $char[$i] = e_capture($1);
7116 0 0         if ($ignorecase) {
7117 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
7118             }
7119             }
7120              
7121             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Eusascii::PREMATCH()
7122             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
7123 0 0         if ($ignorecase) {
7124 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::PREMATCH())]}';
7125             }
7126             else {
7127 0           $char[$i] = '@{[Char::Eusascii::PREMATCH()]}';
7128             }
7129             }
7130              
7131             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Eusascii::MATCH()
7132             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
7133 0 0         if ($ignorecase) {
7134 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::MATCH())]}';
7135             }
7136             else {
7137 0           $char[$i] = '@{[Char::Eusascii::MATCH()]}';
7138             }
7139             }
7140              
7141             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Eusascii::POSTMATCH()
7142             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
7143 0 0         if ($ignorecase) {
7144 0           $char[$i] = '@{[Char::Eusascii::ignorecase(Char::Eusascii::POSTMATCH())]}';
7145             }
7146             else {
7147 0           $char[$i] = '@{[Char::Eusascii::POSTMATCH()]}';
7148             }
7149             }
7150              
7151             # ${ foo }
7152             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
7153 0 0         if ($ignorecase) {
7154 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $1 . ')]}';
7155             }
7156             }
7157              
7158             # ${ ... }
7159             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
7160 0           $char[$i] = e_capture($1);
7161 0 0         if ($ignorecase) {
7162 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
7163             }
7164             }
7165              
7166             # $scalar or @array
7167             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7168 0           $char[$i] = e_string($char[$i]);
7169 0 0         if ($ignorecase) {
7170 0           $char[$i] = '@{[Char::Eusascii::ignorecase(' . $char[$i] . ')]}';
7171             }
7172             }
7173              
7174             # quote character before ? + * {
7175             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7176 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7177             }
7178             else {
7179 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7180             }
7181             }
7182             }
7183              
7184             # make regexp string
7185 0           $modifier =~ tr/i//d;
7186 0 0         if ($left_e > $right_e) {
7187 0           return join '', 'Char::Eusascii::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7188             }
7189 0           return join '', 'Char::Eusascii::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7190             }
7191              
7192             #
7193             # escape regexp of split qr''
7194             #
7195             sub e_split_q {
7196 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7197 0   0       $modifier ||= '';
7198              
7199 0           $modifier =~ tr/p//d;
7200 0 0         if ($modifier =~ /([adlu])/oxms) {
7201 0           my $line = 0;
7202 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7203 0 0         if ($filename ne __FILE__) {
7204 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7205 0           last;
7206             }
7207             }
7208 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7209             }
7210              
7211 0           $slash = 'div';
7212              
7213             # /b /B modifier
7214 0 0         if ($modifier =~ tr/bB//d) {
7215 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7216             }
7217              
7218 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7219              
7220             # split regexp
7221 0           my @char = $string =~ /\G(
7222             \[\:\^ [a-z]+ \:\] |
7223             \[\: [a-z]+ \:\] |
7224             \[\^ |
7225             \\? (?:$q_char)
7226             )/oxmsg;
7227              
7228             # unescape character
7229 0           for (my $i=0; $i <= $#char; $i++) {
7230 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7231             }
7232              
7233             # open character class [...]
7234 0           elsif ($char[$i] eq '[') {
7235 0           my $left = $i;
7236 0 0         if ($char[$i+1] eq ']') {
7237 0           $i++;
7238             }
7239 0           while (1) {
7240 0 0         if (++$i > $#char) {
7241 0           die __FILE__, ": Unmatched [] in regexp";
7242             }
7243 0 0         if ($char[$i] eq ']') {
7244 0           my $right = $i;
7245              
7246             # [...]
7247 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_qr(@char[$left+1..$right-1], $modifier);
7248              
7249 0           $i = $left;
7250 0           last;
7251             }
7252             }
7253             }
7254              
7255             # open character class [^...]
7256             elsif ($char[$i] eq '[^') {
7257 0           my $left = $i;
7258 0 0         if ($char[$i+1] eq ']') {
7259 0           $i++;
7260             }
7261 0           while (1) {
7262 0 0         if (++$i > $#char) {
7263 0           die __FILE__, ": Unmatched [] in regexp";
7264             }
7265 0 0         if ($char[$i] eq ']') {
7266 0           my $right = $i;
7267              
7268             # [^...]
7269 0           splice @char, $left, $right-$left+1, Char::Eusascii::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7270              
7271 0           $i = $left;
7272 0           last;
7273             }
7274             }
7275             }
7276              
7277             # rewrite character class or escape character
7278             elsif (my $char = character_class($char[$i],$modifier)) {
7279 0           $char[$i] = $char;
7280             }
7281              
7282             # split(m/^/) --> split(m/^/m)
7283             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7284 0           $modifier .= 'm';
7285             }
7286              
7287             # /i modifier
7288             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Eusascii::uc($char[$i]) ne Char::Eusascii::fc($char[$i]))) {
7289 0 0         if (CORE::length(Char::Eusascii::fc($char[$i])) == 1) {
7290 0           $char[$i] = '[' . Char::Eusascii::uc($char[$i]) . Char::Eusascii::fc($char[$i]) . ']';
7291             }
7292             else {
7293 0           $char[$i] = '(?:' . Char::Eusascii::uc($char[$i]) . '|' . Char::Eusascii::fc($char[$i]) . ')';
7294             }
7295             }
7296              
7297             # quote character before ? + * {
7298             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7299 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7300             }
7301             else {
7302 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7303             }
7304             }
7305             }
7306              
7307 0           $modifier =~ tr/i//d;
7308 0           return join '', 'Char::Eusascii::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7309             }
7310              
7311             #
7312             # instead of Carp::carp
7313             #
7314             sub carp {
7315 0     0 0   my($package,$filename,$line) = caller(1);
7316 0           print STDERR "@_ at $filename line $line.\n";
7317             }
7318              
7319             #
7320             # instead of Carp::croak
7321             #
7322             sub croak {
7323 0     0 0   my($package,$filename,$line) = caller(1);
7324 0           print STDERR "@_ at $filename line $line.\n";
7325 0           die "\n";
7326             }
7327              
7328             #
7329             # instead of Carp::cluck
7330             #
7331             sub cluck {
7332 0     0 0   my $i = 0;
7333 0           my @cluck = ();
7334 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7335 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7336 0           $i++;
7337             }
7338 0           print STDERR CORE::reverse @cluck;
7339 0           print STDERR "\n";
7340 0           carp @_;
7341             }
7342              
7343             #
7344             # instead of Carp::confess
7345             #
7346             sub confess {
7347 0     0 0   my $i = 0;
7348 0           my @confess = ();
7349 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7350 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7351 0           $i++;
7352             }
7353 0           print STDERR CORE::reverse @confess;
7354 0           print STDERR "\n";
7355 0           croak @_;
7356             }
7357              
7358             1;
7359              
7360             __END__